perm filename GPRINT.RPG[UP,DOC] blob
sn#500382 filedate 1980-02-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00059 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 -*-LISP-*-
C00008 00003
C00012 00004
C00017 00005
C00023 00006
C00029 00007
C00033 00008
C00037 00009
C00042 00010
C00045 00011
C00049 00012
C00054 00013
C00060 00014
C00065 00015
C00070 00016
C00074 00017
C00079 00018
C00083 00019
C00087 00020
C00092 00021
C00096 00022
C00101 00023
C00108 00024
C00112 00025
C00117 00026
C00121 00027
C00124 00028
C00129 00029
C00133 00030
C00139 00031
C00146 00032
C00152 00033
C00158 00034
C00161 00035
C00168 00036
C00174 00037
C00185 00038
C00190 00039
C00194 00040
C00198 00041
C00201 00042
C00203 00043
C00206 00044
C00210 00045
C00214 00046
C00218 00047
C00220 00048
C00222 00049
C00226 00050
C00229 00051
C00234 00052
C00239 00053
C00241 00054
C00246 00055
C00250 00056
C00254 00057
C00259 00058
C00262 00059
C00362 ENDMK
C⊗;
;-*-LISP-*-
(comment a fast pretty printer)
;this file was written by Richard C. Waters Feb. 1978.
;all comments and bugs should go to DICK@AI
;this comes from the file #print the functionality is the same, however
;every |#| has been changed to a G so that there will not be any conflict
;with the |#| readmacro.
; --- AN ADVERTISMENT FOR THIS PRINTER ---
;the goal of this printing package is to produce a general purpose printer which
;combines the best features of PRINT and GRINDEF while correcting some of their
;deficiencies.
;GOOD FEATURES OF PRINT RETAINED
; PRINLEVEL and PRINLENGTH abbreviation,
; printing of HUNKs in a recognizable way,
; reasonable speed.
;GOOD FEATURES OF GRINDEF RETAINED
; nice formatting of output,
; grind-functions for specifying your own formatting.
;BAD FEATURES CORRECTED
; GRINDEF is too slow, this is improved by simplifying the look ahead and virtually
; eliminating consing.
; the old printers blow up on circular lists, this is fixed by putting in a module that
; checks for circularity. (this can be disabled if you don't like the overhead it
; creates).
; there isn't any way to stop the old printers, you can turn off seeing the output, but
; you still have to wait until it's done computing unless you type a ↑g and wipe
; out the whole environment. this is fixed by providing an interrupt function
; which causes the printer to immediatly abort and return normally.
; structure, and printing nothing if the object passed to Gprint is a naked ||.
;NEW FEATURES ADDED
; a new abbreviation mode is introduced. special variables PRINSTARTLINE and PRINENDLINE
; can be used to specify how many lines to print out. for example you could
; specify that only the first 4 lines should be printed out. an interrupt
; function is provided so that you can see the rest of the output if you want to.
; this works if the output is at top level, or from inside a program.
; a new format for grinding is introduced. it prints out a block of data in a tabular
; format where the width of the columns is automatically generated. it is useful
; for increasing the readability of densely printed stuff.
; a new method of specifying a grinding format is introduced. It allows you to construct
; a template which controls the format of printing. it can be used to produce a
; wide variety of formats, and is considerably simpler than writing a grind
; function.
; The Gprinter doesn't print anything to the left of the column position that
; it starts printing in. This is very usefull when the Gprinter is
; being called as a subroutine by some other function which is pretty
; printing something (eg when it is being used like SPRINT).
; Gprin1 prints out nothing for '||' if '||' is passed to it as a single atom,
; and prints '||' for it inside a structure. This is handy since you
; can have a function return '|| and not have to see anything printed out.
;IN DEPTH DOCUMENTATION OF HOW TO USE THE GPRINTER
;
;this documentation is arranged into a set of sections which describe more and more
;advanced levels of interaction with the printer. what you should read depends on
;what you want to do. if you just want to load it in and use it without
;creating any of your own formats for printing things, then just read sections
;0 and 1. In order to make your own templates, and/or functions for
;formatting, you need to read about GGRIND-TEMPLATEs and GGRIND-FNs. (you will
;have to read a good deal of the rest in order to realy understand them) In
;order to set up your own printing system you will have to read everything
;including the implementation notes.
;
;The code for the Gprint programs appears after this initial set of comments.
;It is written in terms of a bunch of macros which are in the file dick;util >.
;Since there is some difficulty in understanding these macros, if you are
;not familiar with them, the end of this file contains a completely macro
;expanded version of these same programs.
;
;(the functions and special variables in this file start with G so that they will
; not collide with any names in other program packages. (for added safety a lot
; of things which are considered internal to the package begin with G1))
;
;SECTION 0 (JUST LOAD IT IN AND USE IT AS THE TOP LEVEL TTY PRINTER)
;
;HOW TO LOAD GPRINT
; a. execute (fasload Gprint fasl dsk liblsp)
;
;HOW TO START UP GPRINT
; a. execute (G1set-up-printer) this sets 'Gprin1 as the value of prin1
; (thus making it the default printer) and sets up ↑S and ↑C (see below).
; (you can just do (setq prin1 'Gprin1) if you don't want the control
; characters)
; b. DO NOT change the fsubr properties of prin1 or princ since Gprint uses
; them.
;
;HOW TO GET RID OF THE GPRINTER
; a. execute (G1rem-printer) this undoes all of the actions of
; G1SET-UP-PRINTER and gets rid of the functions in the Gprint package.
; The primary use is to save space before creating a dumped version,
; however, Gprint really doesn't take up much space.
;THE BASIC STRUCTURE OF THE GPRINTER
;
;the Gprinter is implemented as three sets of programs which communicate with
; each other through two narrow bottle necks.
; 1. top level print functions like GPRINT, PRINL, and GRINDEF (see section 1)
; these form an easy interface for getting something printed. there are
; also a set of special varibles which control the format of printout
; (see section 1)
; 1-2. all of these functions eventually call G1PRINTER. this function then
; communicates the critical information about what to print and how with
; (2.) below. this is done partly through argument passing and partly
; through a set of special variables.
; 2. this set of programs formats an object for output. in doing this it
; creates an intermediate structure which tells how to format each part
; of the object if that part will not fit on one line. these functions
; use a set of special variables to communicate with each other. in
; addition they use atom properties and a few special variables to get
; information directly from the user. Furthermore, these routines are
; specifically designed so that they can be modified by the user.
; (each of these mechanisms is described in detail below)
; 2-3. the net result of the formatting functions in (2.) above is a sequence
; of calls on the function G1ENTER-OBJ. this function forms the complete
; interface with (3.) below. G1ENTER-OBJ constructs an ellaborate intermediate
; structure which is represented in several special variables. this part
; and (3.) below are extreamly convoluted and are not intended to be
; modified by the user.
; 3. the function G1PRINTOUT actually decides what will go where and prints
; the object out. it uses a number of special variables to communicate
; with itself and G1ENTER-OBJ.
;
;the general high speed of the GPRINTer is due to two things:
; 1. the GPRINTer does very little look ahead, in particular, it calls
; FLAT(SIZE/C) only once on each atom in the structure to be printed, and
; never calls it with a non atomic argument.
; 2. the GPRINTer does almost no consing. rather it does its own storage
; management including keeping a queue in an array. this greatly reduces
; garbage collections. the only consing is the fixnum consing which is
; neccessary because some special variables have fixnum values.
; fortunately most of these values are relatively static and/or small.
;SECTION 1 THE BASIC USER FUNCTIONS AND ABBREVIATION CONTROL VARIABLES
;
;the functions GPRINT, GPRIN1, and GPRINC are analogous to the functions
; PRINT, PRIN1, and PRINC. they are LSUBRs and take two arguments. the first
; must be an object to print out. the second can be either: a file, a list
; of files, NIL, or missing (in the last two cases the default files
; specified by ↑R, ↑W, and OUTFILES are used as output destinations)
;
;there a several special variables which can be used to control the amount of
; abbreviation which is performed by the printer. in each case if the
; variable has the value NIL then there is no abbreviation corresponding to
; that variable. (The Gprinter requires that all of these variables be BOUND
; and makes sure that this is the case when it is loaded in. (this is done
; by the function G1SET-UP-GLOBALS which gives all of the controling
; variables which are unbound a default value of NIL (ie no abbreviation)))
; 1. PRINLEVEL: just like PRINT, GPRINT prints G for lists which are at a
; depth greater than PRINLEVEL. It extends the definition of elision used in
; PRINT in that it forces prinlength to 3 at the deapest level printed. This
; is so that you don't see a long string of G's at that level.
; 2. PRINLENGTH: just like PRINT, GPRINT prints ... for the ends of lists
; which are longer than PRINLENGTH. It extends the definition of elision
; used in PRINT in that if only one element of a list is going to be omitted
; and that element is an atom, then it is not omitted.
; 3. PRINENDLINE: GPRINT counts the lines it prints out (starting with the
; first line as line 0) and stops printing after printing the
; PRINENDLINEth line. if truncation occures, --- is printed at the end
; of the last line (if there is room). the printer then immediatly stops
; executing and returns no matter how large the output object is.
; 4. PRINSTARTLINE: if PRINSTARTLINE is greater than zero, then GPRINT skips
; over the initial lines of output and does not start to print out untill
; the PRINSTARTLINEth line is reached. (note that if PRINSTARTLINE is
; greater then PRINENDLINE nothing is going to print out) (also note that
; like PRINLEVEL and PRINLENGTH, PRINENDLINE and PRINSTARTLINE must be
; non-negative.)
; 5. GCHECKRECURSION: if this variable is non null then, GPRINT checks for
; circular lists and prints ↑G for circular references where G is the number of
; cars and cdrs separating the two references to the item. for example,
; t1=(1 2 ↑2) implies that (eq (cdr t1) (caddr t1)).
;
;there is a special variable PRINMODE which specifies what format GPRINT
; will use to print things out. (this is discussed more fully below)
; PRINMODE can take on two basic values:
; 1. 'CRUSH gives you crushed together output similar to PRINT. atoms are
; not broken over line boundries.
; 2. 'GRIND (or NIL) gives you nicely formated output like GRINDEF. (there
; are a number of ways that you can control what this looks like
; (see below))
;
;Hunks are printed out in a format different from the way PRINT prints them. Each
; hunk is printed as '{' cxr1 cxr2 cxr3 ... cxr0 '}'. Thus
; (hunk 1 2 (hunk 3 4 5) 6) prints as
; {1 2 {3 4 5} 6}.
;there are two functions which are intended to be put on interrupt characters.
; (calling G1SET-UP-PRINTER sets these up)
; 1. GPRINTABORT (↑S) causes the printer to stop and return normally.
; 2. GCONTINUE (↑C) will cause the printer to resume printing from where it left
; off printing the last object which was truncated by ↑S or prinendline. Note
; that this may not be the last thing which was Gprinted. Also, it only works on a
; line by line basis so there may be some duplication if the object printout was
; truncated by ↑S (GPRINTABORT). GCONTINUE uses CURSORPOS and is only intended
; to work on output devises which support CURSORPOS.
; A special endpage function (G1ENDPAGEFN) is
; provided because the system one does not correctly do MORE
; processing with the printout produced by GCONTINUE (I think that this has
; something to do with GCONTINUE being on an interrupt character). this new
; endpage function is installed by G1SET-UP-PRINTER.
;
;there are three functions (PRINL, PRINL1, and PRINLC) which are analogous to
; GPRINT, GPRIN1, and GPRINC except that they allow you to specify the
; control parameters PRINLEVEL, PRINLENGTH, PRINENDLINE,
; PRINSTARTLINE, and PRINMODE as arguments rather than by setting the
; global variables. useing PRINL as an example, the argument order is:
; (PRINL object level length endline startline mode file) as an added
; conveniance, any of these arguments (except the object) can be omitted
; and will take on a default value (of NIL which means no abbreviation)
; as long as there is no ambiguity. the only abiguity that can arize is
; with the four numeric parameters (level, length, endline, and
; startline). with these, you must specify an initial subset of them.
; the most common way to call PRINL is (PRINL object file) this prints
; out the entire object on file (much like SPRINT). other valid calls on
; PRINL are: (PRINL foo 3 4 'grind tyo) ;this sets level=3 and length=4
; (PRINL bar nil nil 4) ;this sets endline=4
;
;there is a redefinition of the function GRINDEF which calls GPRINT. it is an
; FSUBR and takes arguments just like the old grindef. IE the first argument
; (which may be omitted) is a list of properties to grind. this list of
; properties is used in conjunction with the list of properties in the variable
; GRINDPROPERTIES in order to decide what properties of the specified atoms to
; print out. the remaining arguments to GRINDEF are atoms.
;
;there are three functions GEXPLODE, GEXPLODEC, and GEXPLODEL which correspond
; to GPRIN1, GPRINC, and GPRINL. They don't actually print anything out,
; rather they return a list of the characters which would be printed out
; if the whole structure fit on one line. (note that this includes all
; abbreviation which would have been used. GEXPLODEL allows you to
; directly specify the abbreviation parameters.) For example,
; (Gexplode '(1 2 3)) => '(/( /1 / /2 / /3 /))
; but if PRINLENGTH = 2 then it returns:
; (Gexplode '(1 2 3)) => '(/( /1 / /2 / /. /. /. /))
; as long as PRINMODE is 'GRIND then all macro inversion etc. happens ie:
; (Gexplodel '(1 (quote 2)) 'grind) => '(/( /1 / /'/2/))
;IMPLEMENTATION NOTE ON SECTION 1 (THE FUNCTION G1PRINTER)
;
;the function G1PRINTER takes 3 arguments:
; (G1PRINTER code object parameters) The first is a code which specifies what
; type of printing to do. The second argument is the object to print, and the
; last indicates the files to print out on. The code is a number which is
; decoded bit by bit as follows:
; bit0 - if 1 then atoms are PRINCed instead of PRIN1ed.
; bit1 - if 1 then a TERPRI is done before starting to print, and a
; space is printed at the end (like PRINT)
; bit2 - if 1 then the third argument is taken to be, not just
; files, but also an explicit specification of the abbreviation
; parameters (prinlevel prinlength prinendline prinstartline
; prinmode) (the way these are pattern matched out of the string
; provided is discussed as part of the discusion of PRINL above).
; bit3 - if 1 then G1PRINTER does an explode instead of actually
; printing anything.
; The function G1PRINTER is used to implement the functions GPRINT etc.
;
;G1PRINTER performs several main tasks:
; 1. if it is reentered while another call on it has not yet completed, it
; rebinds all of the special varibles used by the GPRINT system so that
; the old invocation will be protected while the current call is completed
; (the special variable G1NOWPRINTING is used as a flag to tell whether or
; not the Gprinter is being reentered). this enables the GPRINTer to work
; perfectly when it is reentered, the only change in its actions is that
; it creates a certain amount of garbage when it reinitializes itself
; whereas in general it does almost no CONSing.
; 2. G1PRINTER takes care of outputing crlf before output of GPRINT and
; GPRINL and a space after (as controled by G1PRINT-LIKE).
; 3. it takes care of printing || differently if it is the object to be
; printed than if it is in the object to be printed.
; 4. before calling the formatting routines to print out the object, G1PRINTER
; sets up a CATCH which enables G1PRINTABORT (↑S) to stop the printer.
; this is also used to implement stopping when prinendline is reached.
; 5. the special variable G1TRUNCATED is used to keep track of whether the
; output is truncated or not, and if so on what line. if non-null, it holds a
; list of all the information needed to resume printing in the right place.
; This is used by G1CONTINUE to decide where to start printing out.
; G1PRINTER sets up the value of G1TRUNCATED whenever G1PRINTABORT or
; PRINENDLINE triggers the truncation of output. G1TRUNCATED is a list
; of the following components:
; 1. the CURSORPOS (line . column) where printing stopped.
; 2. the indentation where printing started in the first place.
; 3. the primary output file (G1MAINFILE).
; 4. the CODE which should be used when calling G1printer in order to
; continue printing out the truncated object.
; 5. the MAKNUM of the object being printed. (the maknum is used so
; that this will not prevent the object from getting garbage
; collected)
; 6. the abbreviation parameter list which should be passed to
; G1printer in order to continue printing the object. it has the form:
; a. the current prinlevel
; b. the current prinlength
; c. a prinendline of NIL
; d. a prinstartline of the line where truncation occured.
; e. the current prinmode
; f. the files being printed on.
; 6. most importantly, G1PRINTER translates the format control information into the
; form that the formatting routines expect. (see the discussion below of
; the special variables used to communicate with the format funcions.) In addition, the
; function G1FORMAT-INIT is called to set up the special variables which
; are used during the formatting and printout processes.
;
;if you wish to dispence with G1PRINTER and write a program which directly
; calls the format functions, you must make sure that the above variables
; are at least bound, and you must call G1FORMAT-INIT before calling the
; format functions. also note that you will be loosing the features which
; are implemented directly by G1PRINTER unless you make provision for them.
;THE SPECIAL VARIABLES USED BY THE TOP LEVEL FUNCTIONS:
;
;Variables which are set by the user to control certain fucntions:
; Gcheckrecursion (t/nil) this controls checking for circularity.
; prinlevel (a non-negative number or nil) this controls G abbreviation if
; structures get too deep.
; prinlength (a non-negative number or nil) this controls ... abbreviation if
; structures are too long.
; prinmode (a keyword, or a template (see below)) this controls the format of
; output it is discussed fully in the section on templates below.
; prinendline (a non-negative number or nil) this controls the number of lines
; which are printed out.
; prinstartline (a non-negative number or nil) this controls which line is the
; first line actually printed out.
; ↑r (t/nil) if T this implies that the variable OUTFILES will be used to
; decide what files to output onto. (this is the same convention as with PRINT).
; ↑w (t/nil) if NIL this implies that output will be done to the file in the
; variable TYO. (This is completely orthoganal to ↑R and is the same convention
; as with PRINT)
; outfiles (a list of files) this is a list of files to perform output to.
; tyo (a file) this is the file which is the default 'tty' file.
; grindproperties (a list of properties) this controls what the default properties
; displayed by GRINDEF will be.
;
;Variables which are used for communication between top level functions:
; G1print-like (t/nil) if T then a space is put after, and a crlf before what
; is being printed. this is used by G1PRINTER.
; G1nowprinting (t/nil) if T this says that there is an unfinished call on
; G1PRINTER on the stack. In that case all the volitile special variables
; are rebound before starting up another call on G1PRINTER in order to
; protect the state of the old call. This is used by G1PRINTER.
; grindef (the last argument to GRINDEF) this is used to implement the fact
; that (GRINDEF) does what ever the last call on GRINDEF did. THis is used
; by GRINDEF.
; G1mainfile (a file) this is a file which has been selected as the primary
; output file. It is used to make formating decisions based on such things
; as line length. In addition GCONTINUE tries to make its output look
; perfect on G1MAINFILE while it ends up only OK on the other files, if any.
; it is either the first file specified (if literal files were specified to
; a printing function) or the first file in OUTFILES if ↑R and ↑W are both
; T, or otherwise it is the value of TYO. (if it should turn out that
; G1MAINFILE failed to end up as a valid file things wouldn't work out
; right even if you were only GEXPLODEing.)
; G1truncated (nil or a description of an object which was truncated) this is
; created by G1PRINTER in order to communicate with GCONTINUE. It holds
; all of the information which GCONTINUE needs to finish printing
; something. (It is discussed in detail above.)
;Variables which form the interface between the top level functions and the
; format functions:
; G1princ-atoms (t / nil) is t if atoms should be PRINCed instead of PRIN1ed.
; G1files (list of files) holds a list of the files to print onto. (it can be NIL which
; implies that ↑R ↑W and OUTFILES will be used to decide where output will go.)
; G1checkrecursion (t/nil) holds the value of GCHECKRECURSION.
; G1prinlevel (positive number) holds the value of GPRINLEVEL except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; G1prinlength (positive number) holds the value of GPRINLENGTH except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; G1prinlendline (positive number) holds the value of GPRINENDLINE except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; G1prinstartline (positive number) holds the value of GPRINSTARTLINE except
; that it is always a number. instead of NIL, a 0 is used to inhibit
; abbreviation.
; G1prinmode (positive number) holds the value of PRINMODE (see the discussion of templates
; below) except that if PRINMODE is a keyword (such as GRIND) then the
; keyword is translated into a template.
; G1exploding (t/nil) is t if the Gprinter should produce a list of characters
; rather than print anything out.
; G1explode-result (a list of characters) (initialized to nil) is used to pass
; the results of Gexploding back up to G1PRINTER. it collects the
; nreverse of the result.
; 1st arg of G1format-dispatch is the template to use when formatting the
; object. this is taken from the variable G1PRINMODE.
; 2nd arg of G1format-dispatch is the object to be formated.
;SECTION 2 CALLS ON THE FUNCTION G1ENTER-OBJ
;
;In order to print something, a sequence of calls on the function G1ENTER-OBJ
; is created. In order to understand the capabilities of the Gprinter,
; it is important to look at what a sequence of calls on G1ENTER-OBJ is like.
;
;the functions G1ENTER-OBJ takes three arguments: (G1enter-obj obj pcode lcode)
; In addition it looks at two global variables: G1fcode and G1bcode (the MACRO
; G1ENTER-FORMAT (G1enter-format fcode bcode) is available for setting these two
; global variables. The MACRO G1ENTER-FORMAT&OBJ (G1enter-format&obj fcode
; bcode obj pcode lcode) sets these two variables and then calls (G1enter-obj
; obj pcode lcode).) The separation between the two sets of inputs is
; motivated by the fact that the function invocation which sets the
; format, is often different from the one which decides what object to
; print. Put another way, the format depends on the context the object
; is in, while how the object itself is printed depends on the object
; itself. This will be discussed more fully below.
;
;Logically, G1ENTER-OBJ takes five arguments:
; 1. obj -- an object to be printed. The formatting functions (see below)
; convert a thing to be Gprinted into a sequence of objects to be
; printed. this sequence includes list delimeters on an equal footing
; with atoms in the thing to be printed. for example when Gprinting
; '(list (cons var1 var2) var3 var4)' the following sequence of 10 objects is
; created '/( list /( cons var1 var2 /) var3 var4 /)'. The standard
; Gprinter only calls G1enter-obj with atomic objects, but a list or
; hunk could be used; however, it will be treated just like an indivisable atom.
; 2. pcode -- the printing code is one of {princ, prin1, nil} and specifies
; whether to use PRIN1 and FLATSIZE, or PRINC and FLATC when working
; with the object. a pcode of nil indicates that the object has been
; omitted, and there is no object to be printed corresponding to this
; call on G1enter-obj.
; 3. lcode -- the list code is one of {start, end, nil}. It is used to
; encode the nested structure of the thing being printed. It is
; motivated by the nesting in lists, but need not correspond to any
; actual delimiters, nor be limited to lists. For example the cxrs of
; a hunk, which are printed out inside '{}'s, are a nested structure like
; any other from the point of view of the calls on G1enter-obj. The
; lcode of END means that this object is the last object in a
; substructure. The lcode NIL indicates that this is neither the first
; nor last object in a substructure.
; the lcode START indicates the start of a nested structure. In
; addition, it indicates that the obj parameter is not an object to be
; printed, but rather the amount of indentation to use when printing out
; the substructure which starts here. This requires that an extra call
; on G1ENTER-OBJ be made at the start of each substructure. This extra
; call on G1ENTER-OBJ (the one with lcode=start) is a 'header cell' for
; a nested structure. One the one hand, it is not part of the nested
; structure, but rather just introduces it; it contains general
; information which applies to the whole substructure (like the
; indentation) and the fcode and bcode (see below) for the substructure
; as a whole. On the other hand, the header cell is often operated on
; as a unit, refering to the entire substructure.
; the example above '(list (cons var1 var2) var3 var4)' can now be seen
; to generate 12 calls on G1ENTER-OBJ:
(declare '| obj pcode lcode
(G1enter-obj 6 nil 'start)
(G1enter-obj '/( 'princ nil)
(G1enter-obj 'list 'prin1 nil)
(G1enter-obj 6 nil 'start)
(G1enter-obj '/( 'princ nil)
(G1enter-obj 'cons 'prin1 nil)
(G1enter-obj 'var1 'prin1 nil)
(G1enter-obj 'var2 'prin1 nil)
(G1enter-obj '/) 'princ 'end)
(G1enter-obj 'var3 'prin1 nil)
(G1enter-obj 'var4 'prin1 nil)
(G1enter-obj '/) 'princ 'end) |)
; the indentation is '6' in the two substructures because LIST and CONS
; are being printed in functional notation which calls for an
; indentation of (+ (the length of the open delimeter (here 1))
; (the length of the function name (here 4))
; (the amount of spacing over ie 1)) = 6.
; 4. fcode -- a keyword which must be one of {never, normal, tblock, block, always}
; It describes the circumstances under which a crlf will be printed
; before the object to be printed. (NOTE that if this fcode is
; associated with a call on G1ENTER-OBJ which starts a substructure, then
; the 'object being printed' refered to below, is the entire
; substructure. also note that the 'prior object printed' may also
; refer to an entire substructure.)
; ALWAYS -- a crlf is always put before this item.
; NEVER -- a crlf will never be put before this object, unless the
; object is too long to fit on the end of the current line. If the
; object is the start of a substructure then a crlf is never
; inserted no matter how long it is. (in general non-atomic
; structures are not given 'NEVER fcodes.)
; In order to make it more likely, that NEVER really means never, the
; printer works with a logical line length which is 5 characters
; shorter than the actual line length. However, when it comes to
; processing a NEVER, the Gprinter uses the actual line length.
; The 5 character cushion is available only for printing NEVER objects
; NORMAL -- a crlf is put before this object if and only if the substructure
; containing this object was to long to fit on the end of the line
; it started on. Note that this is not a function of the object
; itself, but rather a function of the containing substructure.
; This is used to generate standard list output format: either,
; every element of the list is on the same line, or each one is on
; a separate line.
; BLOCK -- a crlf is put before this object if and only if either,
; this object is a substructure which has somewhere in it an ALWAYS
; code, or the prior object at the same level did not fit on one line, or
; this object is too long to fit on the end of this line.
; This is used to generate 'block' output where several list
; elements are put on each line.
; TBLOCK -- a crlf is put before this object in exactly the same
; situations as with the BLOCK code. the difference is that when
; the objects are printed out, tabing is done in order to line them
; up in columns. (this variant of BLOCK can be much more readable.)
; NOTE that the Gprinter NEVER inserts two crlfs in a row.
;
; The routine which does output goes inside a substructure, and breaks
; it up in only two cases. The first case is when the substructure is
; simply too long to fit on one line. (the outputer first does as much
; as possible given the fcodes of the containing stuctures to start the
; substructure as far to the left as possible.) The second case occures
; if the substructure contains an ALWAYS fcode somewhere inside itself.
; If the outputer looks inside a substructure, then that substructure
; may be broken up over several lines in order to make it fit.
; Otherwise, the substructure will appear as a unit on one line.
; 5. bcode -- this specifies the number of blanks to print out AFTER
; printing this item (usually 1 or 0). Note, that the bcode associated
; with an lcode of START is actually printed out after the object
; associated with the corresponding END lcode. IE it appears after the
; entire logical object. The bcode (if any)
; associated directly with the END lcode is IGNORED. there are no
; blanks printed out in conjunction with processing the START lcode.
; Note further, that blanks are never printed as the last characters
; on a line. therefore the bcodes associated with those objects that
; happen to end up on the end of a line are effectively ignored.
;
;now we can look at a complete example of the sequence of calls generated by
; the example, assuming that it is being printed in standard grind format.
;
(declare '|'(list (cons var1 var2) var3 var4)' leads too:
fcode bcode obj pcode lcode
1 (G1enter-format&obj 'never 0 6 nil 'start)
2 (G1enter-format&obj 'never 0 '/( 'princ nil)
3 (G1enter-format&obj 'never 1 'list 'prin1 nil)
4 (G1enter-format&obj 'never 1 6 nil 'start)
5 (G1enter-format&obj 'never 0 '/( 'princ nil)
6 (G1enter-format&obj 'never 1 'cons 'prin1 nil)
7 (G1enter-format&obj 'never 1 'var1 'prin1 nil)
8 (G1enter-format&obj 'normal 0 'var2 'prin1 nil)
9 (G1enter-format&obj 'never ← '/) 'princ 'end)
10 (G1enter-format&obj 'normal 1 'var3 'prin1 nil)
11 (G1enter-format&obj 'normal 0 'var4 'prin1 nil)
12 (G1enter-format&obj 'never ← '/) 'princ 'end)
if the line length were 21 then this would print out as:
(list (cons var1
var2)
var3
var4) |)
;
;In order to get a deaper understanding of how this works, consider the
; following trace of how the output part of the Gprinter would interpret
; this in order to produce output. Suppose that the line length on the
; primary output device was 21. The output section processes the calls
; on G1ENTER-OBJ one at a time (it actually does this as a coroutine with
; the functions which produce the calls on G1ENTER-OBJ, but this is only an
; efficiency issue (it reduces the amount of temporory storage needed)).
; Note that one question which the outputer often asks is how long
; something is. For effeciency, this is computed incrementally, but
; this aspect will be ignored here.
; Suppose the printer started out in column 0. When presented with
; the 1st call on G1ENTER-OBJ it asks whether or not the corresponding
; object (in this case the whole expression) is too long to fit on one
; line. Here the object is 33 chars long and there is only space for
; 21. The output point is already at the start of a line, so the system
; looks inside the substructure in order to see how to break it up.
; The system then looks at the 2nd call. the fcode is NEVER, so no
; crlf is done. a /( is printed out. the bcode is 0 so no blanks are
; printed.
; The 3rd call also has a NEVER fcode, so no crlf is printed. a
; 'list' is printed (prin1ed since that is specified). then 1 blank is
; printed as specified by the bcode.
; The 4th call is a substructure header cell (as was the 1st). It
; has an fcode of NEVER so no crlf is printed, However, the current
; output point is column 6 (the first column is 0), and the length of
; this substructure is 17. as a result, it is not going to fit on this
; line. as a result the system goes down inside it to see how it can
; get broken up. (if it had been shorter (say 10) then the system
; would have printed all of it out (calls 4-9) without looking at any of
; those calls in detail.)
; Since the system is looking inside, it looks at calls 5,6, & 7.
; they all have NEVER fcodes so they just print things out (even though
; we are getting closer and closer to the end of the line). They print
; out |(cons var1 |.
; Call 8 has an fcode of NORMAL. this specifies that a crlf should
; be inserted if the containing substructure is being broken up (which
; it is). (note that effectively the output system only looks at the
; fcode if the superior is being broken up.) As a result a crlf is
; done. Note that if the fcode had been BLOCK or TBLOCK then the
; system would have done a crlf because there isn't room to print the
; object in call 8 in the space left on the line. Further if the fcode
; had been NEVER the system would still have done a crlf as an emergency
; measure since you just can't print 'var2' in the space left.
; After doing a crlf for call 8 the system spaces over to the
; current indentation (which is 12 6+6 for the two substructures which
; have been broken up.) The system then prints |var2|.
; It then looks at call 9. This has a NEVER fcode and so the
; system prints out /). In addition, call 9 has an END lcode. As a result, the
; system prints out a blank because a bcode of 1 was specified in the call (call
; 4) which was the header for this substructure. The current indentation is
; popped back to 6 corresponding to the one substructure which the system is
; down in.
; Call 10 has a NORMAL fcode so the system does crlf, and indents
; to the 6th column. It then prints |var3 |
; call 11 also has a NORMAL fcode so the system again does crlf,
; indents to 6 and then prints |var3|. (Note here that if the fcode
; had been BLOCK then the system would not have done a crlf since the
; object actually would fit on the same line as call 10.)
; Finally call 12 causes the outputer to print /) and pop up out of
; the structure being printed.
;SECTION 3 TEMPLATES
;
;As stated above, everything in the printer eventually boils down to a
; sequence of calls on G1ENTER-OBJ. In order to make it easier to get
; the correct sequence of calls generated, there is a structure called a
; template. A template in conjunction with a few conventions specifies
; what the sequence of calls will be. The conventions specify what the
; open and close delimeters are, and what their fcodes are. In addition
; they specify what all of the bcodes are, and the order in which the
; internal items of each substructure will appear. The template
; specifies the indentation, and what the fcodes of the internal items
; of each substructure will be.
; 1. the fcode and bcode associated with the header cell for a
; substructure is inhereted from the fcode and bcode expected of it
; based on its position in the structure which contains it. (note
; the highest level call has an fcode of NEVER and a bcode of 0 in
; all situations.) The template specifies the indentation which
; goes in the header cell.
; 2. the second and last calls for a substructure are the open and
; close delimiters respectively. the second call (the open delimeter) is /(
; for a list and /{ for a hunk. Its fcode is NEVER (so that it will always
; appear on the line the thing printed out starts on) and its bcode is nil.
; The last call (the close delimiter) is /) for a list and /} for a hunk. Its
; fcode is never (so that it will always be on the same line as the last item
; in the list or hunk being printed) and as noted above its bcode is ignored
; by the system.
; 3. The substructure structure of the calls on G1ENTER-OBJ follow
; exactly the tree structure of the thing being printed.
; 4. for a list, the elements of the list make up the 3rd through
; next to last calls. They each have a pcode of PRIN1 (or PRINC
; if G1PRINC-ATOMS is non-null). They each have a bcode of 1
; except the last element of the list (the next to last call)
; which has a bcode of 0. The template specifies the fcodes of
; these calls.
; 5. Hunks are exactly analogous with the cxrs appearing in the
; order 1,2,3, ... ,0.
;a template has a nested structure corresponding exactly to the nested
; structure of the thing being printed, and therefore also corresponding to the
; nested structure of calls on G1ENTER-OBJ created. They are motivated by the
; observation that the sequence of fcodes desired, for the internal items of a
; substructure usually takes the form of some initial sequence followed by an
; unbounded repeating pattern . Templates simulate this by being recursive
; through their cdrs. Similarly, they are often circular through there cars.
;
;the following is a 'grammer' for templates:
; template := explicit-temp v NIL
; explicit-temp := ( indent-count item-temp*n )
; indent-count := number v NIL
; item-temp := ( {NEVER v ALWAYS v NORMAL v BLOCK v TBLOCK} . template )
;
; A template of NIL indicates that the template mechanism is not being
; used, and the format functions (see below) use other means for
; deciding what sequene of calls on G1enter-obj to create.
; An indent-count of NIL indicates that the indent code to use is
; (+ (Flatsize (first of list)) 1 (flatsize open-delimeter)).; This is
; used in creating standard functional indentation.
;
; the template specifies the indent-count, and for each internal
; item in each substructure, the fcode to use for it, and a template to
; use when formatting its internal strucutre. for example, the following
; template (shown as Gprint would print it) could be used to make
; everything print out in lisp function format. (it could have been used
; to generate the example in the previous section.)
; '(nil (never . ↑3) (never . ↑4) (normal . ↑5) . ↑1)
; Note that it is heavily recursive. Each of the subtemplates is
; itself, and it ends in an endless sequence of NORMAL fcodes.
;
; The example above corresponds to this template in that each substructure has
; an open delimeter with a NEVER fcode, and then two NEVER fcodes followed by
; NORMAL fcodes, and finally a close delimeter with a NEVER fcode. The car
; recursiveness of the template causes every substructure to be treated just the
; same way as the top structure is.
;
;There is a function GMAKE-TEMPLATE (with an associated sub-function
; GMAKE-TEMPLATE1) which can be used to easily generate these circular
; structures. This function allows you to specify a circular structure
; by giving the function a list as an argument which contains ellements of the
; form '(↑ . n)'. the input is copied, and each of these special
; elements is replaced by its nth parent in the new structure. the copy
; is then returned. (note that this does not damage the input, and
; works even if the input is itself circular.) the template above could
; have been created by:
; (Gmake-template
; '(nil (never . (↑ . 3)) (never . (↑ . 4)) (normal . (↑ . 5)) . (↑ . 1)))
;Having discussed templates, we can now give a complete explanation of the
; special variable PRINMODE. This variable can either be one of the
; atoms {GRIND, CRUSH, BLOCK, TBLOCK, MISER}, or a template. The
; variable G1PRINMODE (which actually controls the Gprinting process)
; must always be a template. If PRINMODE is an atom, then the function
; G1printer translates this atom into a template as follows:
; GRIND => nil
; CRUSH => (-900 (never . ↑3) . ↑1)
; BLOCK => (1 (never . ↑3) (block . ↑4) . ↑1)
; TBLOCK => (1 (never . ↑3) (tblock . ↑4) . ↑1)
; MISER => (1 (never . ↑3) (normal . ↑4) . ↑1)
; Looking at these we can see what these modes will do, and more about
; how the formatting works in the Gprinter. The CRUSH template causes
; things to get printed out without formatting except that atoms are not
; broken up accross lines. all of its fcodes are NEVER, so that a crlf
; is only inserted when the very next atom to be printed won't fit on the
; rest of the current line. further the large negative indentation,
; guarrentees that the total indentation will allways be negative. this
; cuases printing to always start out as far left as the intial
; indentation point (note that the Gprinter will never go left of the
; initial indentation point).
; The BLOCK, TBLOCK, and MISER templates are very similar.
; They all specify indentations of 1. Assuming that the only open
; delimiters Gprinted are /( and /{ then this means that substructure
; elements are indented just enough to line up after the open delimiter.
; They all have NEVER as the first fcode, which ensures that the first
; item will be on the same line as the open delimiter. They then give
; all of the rest of the elements the same fcode. For BLOCK, these fcode
; is BLOCK and the resulting output looks like GRINDEF's block format,
; crlfs are inserted before any substructure which will not fit on one
; line, however, if several will fit on one line then they are put
; there. TBLOCK is just the same except that the elements printed out
; are lined up in columns like in a table. MISER prints things out like
; GRINDEF's miser format. The elements of a substructure are either all
; printed on one line, or each is printed on a separate line.
;
(declare '| the following gives comparative examples of these four printing
modes. It is based on the assumption that the line length is 30.
(list f foo bar (list (list a CRUSH mode
b) zap) a b c)
(list MISER mode
f
foo
bar
(list (list a b) zap)
a
b
c)
(list f foo bar BLOCK mode
(list (list a b) zap)
a b c)
(list f foo bar TBLOCK mode (this example assumes that the
(list (list a b) zap) Gprinter only saw the first four
a b c) elements of the list when it decided
what the tab spacing should be. This
is typical of the system's limited
look ahead.)
BLOCK and TBLOCK modes are most usefull for working with data structures. the following is
a data structure Gprinted out in BLOCK format. this saves a great deal of space over MISER
format and is a great deal more readable than CRUSH format would be.
((EXAMP1 CONSTANT1) (CONSTANT1 ←*I1) (←*I1 ←+I1) (←+I1 ←GT1)
((←GT1 CE1) CONSTANT2) ((←GT1 CE0) (JOIN1 CE6)) (JOIN1 EXAMP1) (CONSTANT2 (JOIN2 CE5))
(JOIN2 ←AREF1) (←AREF1 ←A=1) (←A=1 CONSTANT3) (CONSTANT3 ←+I2) (←+I2 ←-I1) (←-I1 ←GT2)
((←GT2 CE0) (JOIN2 CE2)) ((←GT2 CE1) (JOIN1 CE2)))
However, it still isn't all that readable. TBLOCK format (as shown below) is a great
deal more readable. It makes it a lot easier to identify the individual items at the top
level.
((EXAMP1 CONSTANT1) (CONSTANT1 ←*I1) (←*I1 ←+I1)
(←+I1 ←GT1) ((←GT1 CE1) CONSTANT2) ((←GT1 CE0) (JOIN1 CE6))
(JOIN1 EXAMP1) (CONSTANT2 (JOIN2 CE5)) (JOIN2 ←AREF1)
(←AREF1 ←A=1) (←A=1 CONSTANT3) (CONSTANT3 ←+I2)
(←+I2 ←-I1) (←-I1 ←GT2) ((←GT2 CE0) (JOIN2 CE2))
((←GT2 CE1) (JOIN1 CE2))) |)
; The template for GRIND is NIL. This means that the Gprinter
; will look at the structure of the thing being printed in order to
; decide how to format it. (This is discussed fully in the next
; section.) However, this usually ends up with the system having
; selected a particular template to use. One of these is for printing
; out functional forms:
; (nil (never) (never) (normal) . ↑1)
; Note that this is a great deal like an example given earlier except
; that it specifies NIL for the templates of the substructures. This
; is so that after formatting the given list in functional form, it
; will again end up with a template of NIL in order to trigger the
; system to figure out how to print the substructures. this is the
; general way in which grinding proceeds.
; There one level templates for doing MISER, BLOCK, and TBLOCK
; output. analogous to the one level functional form template above,
; they con be used to specify one level of formating, and then they give
; a template of NIL so that new templates will be chosen for the lower
; levels. (these are held in the special variables
; G11level-miser-template, G11level-block-template, and
; G11level-tblock-template.)
; Another interesting template is the one which is used for
; formatting CONDs:
; (nil (never) (never . (1 (never) (normal) . ↑1))
; (always . (1 (never) (normal) . ↑1))
; . ↑1)
; There are two interesting features of this. First, there is an
; always code which is used to insure that if a COND has more than one
; clause, it will go on more than one line no matter how short it is.
; Second, this template is two level while the last one was one level.
; it specifies the format for the COND, and the top level format for
; the clauses before becoming NIL.
;
;There is a function G1SET-UP-TEMPLATES which sets up a bunch of templates
; which are used by the rest of the system. This function is executed
; when Gprint is read in. a number of special variables are used to
; hold the templates which are built up. These variables should not be
; modified by the user. (the variables are G1miser-template
; G1block-template G1crush-template G1fn-template G11level-block-template
; G1defun1-template G1defun2-template G11level-tblock-template G1apply-template
; G11level-miser-template G1tblock-template)
;SECTION 4 THE FORMATTING FUNCTIONS
;
;The formatting functions take in an object to print and a template, and produce a sequence of
; calls on the function G1enter-obj. They don't actually print
; anything, however, they decide exactly how a thing will look when it
; is printed. In particular they implement prinlevel and prinlength
; abbreviation, circular structure abbreviation, and fancy formatting for
; grinding.
;
;The function G1FORMAT-INIT sets up a bunch of internal variables used by the
; format functions, and by G1ENTER-OBJ. It MUST be executed before a
; thing is formated! It reinitializes the world. G1PRINTER calls it
; before calling the formatting functions, if you bypass G1PRINTER you
; must call G1FORMAT-INIT yourself.
;
;as discussed above the main interface into the formatting functions is formed
; by the variables: G1princ-atoms, G1files, G1checkrecursion, G1prinlevel,
; G1prinlength, G1prinstartline, G1prinendline, G1prinmode, and G1exploding.
; Actually, G1files, G1prinstartline, G1prinendline, and G1exploding are not
; used by the formaters, and are just passed on to the function G1PRINTOUT.
; Further, the variable G1prinmode is not currently looked at (it is redundent
; with the template argument to the formaters).
; These variables are discussed above. In addition to them, each format
; function takes two arguments: a thing to be formated, and a template which
; says how to format it. (only G1FORMAT-DISPATCH can take a NIL template).
;
;The function G1FORMAT-DISPATCH takes a template and an item and decides which
; specific format function to call and what specific template to pass to
; it. In order to decide what to do G1FORMAT-DISPATCH looks at several
; features:
; 1. The primary feature is the type of the thing to print. It checks
; whether it is a hunk, list, or atom and uses different formaters
; in the three cases.
; 2. Second if there is a NIL template then it figures out what
; template to use. The interesting case of this is with lists. If
; the template is NIL then G1FORMAT-DISPATCH looks at the property
; list of the car of the list looking for GGRIND-TEMPLATE, and
; GGRIND-FN properties (see below).
; In any event it eventually calls a formatting function with an object,
; and a non-nil template.
;there are a variety of ways to effect the actions of G1FORMAT-DISPATCH
; 1. the variables G1FORMAT-DISPATCH, G1FORMAT-LIST,
; G1FORMAT-HUNK, and G1FORMAT-ATOM, are hooks for attaching your
; own formatting functions. If you give any of them a value, then
; this value will be FUNCALLed whenever the corresponding system
; function would have been. (note that if you write a formatting
; function it must be compatable with all of the restrictions
; described below. G1FORMAT-DISPATCH is a special case.)
;when G1FORMAT-DISPATCH gets a template of NIL then it looks at several
; other things in order to figure out what template to really use.
; 2. if you give an atom a GGRIND-TEMPLATE property then that property
; will be used as a template to print out lists whos cars are the
; given atom. COND, SETQ, and LAMBDA are given GGRIND-TEMPLATE
; properties when Gprint is loaded in.
; 3. the variable G1FN-GRIND-PROPERTIES is a list of properties. If
; an atom has any of these properties, then lists which start
; with it will print out in functional form.
; 4. the variable G1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE holds a template
; which is used when neither 2 nor 3 above are applicable.
; This is initially set up so that functional form is
; the default in this case. (this is what the old GRINDEF did)
; If this variable is set to G11level-tblock-template after fasloading Gprint
; then tab blocking will be done instead by default. This takes a little
; getting used to, but saves a lot of space when printing out on the tty. I
; recommend it.
; 5. the variable G1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE holds a template
; which is used for lists whose cars are not atomic. (except that
; literal applications of lambda expressions have a special
; template which is held in the variable G1apply-template.) This is initially
; set up so that miser format (all the sublists indented 1 space) is used in
; this case (this is what old GRINDEF did). If this variable is set to
; G11level-tblock-template after fasloading Gprint then tab blocking will be
; done instead by default. This takes a little getting used to, but saves a lot
; of space when printing out on the tty. I recommend it.
; 6. If you give an atom a GGRIND-FN property, then that property will
; be FUNCALLed as the format function to use when the atom is the
; first of a list. (again this only applies when the template
; argument to G1FORMAT-DISPATCH is nil). When writing a formatting
; function to use this way you must follow the conventions set
; forth below. QUOTE, DEFUN, PROG, and DO are given special
; formatting functions at load time.
;The functions G1FORMAT-LIST and G1FORMAT-HUNK do the formatting of lists and
; hunks respectively. They have certain tasks they (like any formatting
; function) must perform:
; 1. They take a template as an argument (they could ignore it if they
; wanted to) they car cdr down the template in
; order get the correct fcodes, and indent count.
; 2. they call G1FORMAT-DISPATCH in order to do the formatting of
; EVERY subelement of the structures they are formatting.
; 3. as part of this they observe the convention that the variable
; G1FORMAT-DISPATCH may contain a user redefinition of the dispatching function.
; 4. They handle prinlength abbreviation. (this can be omitted)
; This is done by seeing that they don't output more than
; G1PRINLENGTH things in a substructure. They print |...| to
; indicate that something is being left out.
; 5. they handle prinlevel abbreviation. this is done in conjunction
; with the special variable G1LEVEL. If G1LEVEL is 0 when the
; formater is entered, then this indicates that the prinlevel is
; being exceeded. In this case the formaters output |#|. (It doesn't have to do
; abbreviation, but it must take care of G1LEVEL or else no one
; will be able to do prinlevel abbreviation right.)
; 6. they maintain the value of G1LEVEL (by decrementing it when they
; are entered, and incrementing it when they are exited). G1LEVEL is a
; number which is the difference between G1PRINLEVEL and the depth of
; the current sub-ellement being formated. If a format function
; simply didn't touch G1LEVEL, then it would not act like a level
; of structure from the point of view of the other formatting functions.
; 7. They check for recursion by calling the function G1RCHECK on
; every cons cell they encounter. If G1RINDEX returns something
; which is not EQ to its argument, then this indicates that its
; argument was recursive. In this case the formater should
; output the thing returned and not recurse into the item.
; The recursion checking is done in conjunction with
; the variable G1RINDEX. (this can be omitted, but G1RINDEX must be
; maintained or else no one will be able to do recursion checking correctly)
; 8. They maintain the value of G1RINDEX. G1RINDEX is a number which
; is the number of parents on the path from the current cons cell
; to the root of the top level object being printed. It is used by
; G1RCHECK which maintains an array (G1PARENTS) which holds that
; set of parents. G1RINDEX is maintaned by the formaters by
; saving its value on entry, and restoring this value before exit. If
; a formater doesn't call G1RCHECK, then it doesn't have to do
; anything with G1RINDEX.
; 9. G1FORMAT-LIST has special code to deal with atomic cdrs.
; 10. any formatting function must assume that the fcode and bcode which
; correspond to the object which is passed to it HAVE ALREADY BEEN
; SPECIFIED by the functions that called it. thus it should not
; specify the fcode or bcode for the top level thing it puts out.
; this is related to the tacit assumption that each formater will
; either just put out one thing, or will group everything it puts
; out into one substructure. If it doesn't do that, then it must
; take special steps to be compatable with the fcode and bcode its
; caller specified.
; 11. In line with this, a formater must specify an fcode and bcode BEFORE
; calling G1FORMAT-DISPATCH to deal with some substructure it needs
; to have formated.
; 12. Any formater should be carful that it will not crash on circular
; input even when recursion is not being checked for. that is to
; say that it should never do anything which could cause it to go
; into a loop without making any calls on G1ENTER-OBJ. (such as
; doing a flatsize of a non-atomic object.)
;The user can influence the actions of the formatting functions.
; 1. the variables G1OPEN-DEL and G1CLOSE-DEL can be used to modify
; the delimiters to be used by the formaters. setting them
; non-null cuases them to be used as the delimiters by the next
; call on a format function which recognizes them. However, they
; ONLY effect ONE call on the format functions. They do not cause
; a perminant change. the feature is used by the macro
; GMAKE-INVERT-QUOTE-FN which generates special format functions
; which do read macro inversion. (see below)
;the function G1RCHECK is a utility which is called by the formatting
; functions in order to check for recursive structures. It takes one
; input, an item. it either returns that item, or if G1CHECRECURSION
; is non-null and if the item is a recursive reference, G1RCHECK
; returns an atom of the form G↑ where G is the number of cars and
; cdrs in the path from the first instance of the item, to this
; recursive instance of the item.
; In order to do this, G1RCHECK maintains an array (G1PARENTS)
; which contains the cells which are the ancesters of the current cell
; being checked. if that cell turns out not to be recursive, then it
; is put in the end of this array. The variable G1RINDEX points to
; the first free slot in the array G1parents. G1RCHECK increments
; G1RINDEX whenever it puts a new item in G1PARENTS, but it never
; decrements it. It is up to the formatting functions which call
; G1RCHECK to decrement G1RINDEX.
; The combination of G1PARENTS and G1RINDEX act like a stack.
; This stack follows the stack like order in which the formatting
; functions move over a thing to be printed. each call to G1RCHECK
; pushes a new item onto this stack. The formatting functions must see
; to it that these items get popped off of the stack. In order to do
; this each one saves the value of G1RINDEX when it starts to work,
; and then restores that value of G1RINDEX before it returns. this
; reflects the fact that each formatting function works on a single
; subtree and thus the state of G1PARENTS should be the same before
; and after the formatter is called.
;
;WRITING YOUR OWN FORMAT FUNCTIONS
;
;The easiest way to specify a special output format is through a template
; installed as the GGRIND-TEMPLATE property of some atom.
; However this may not be flexable enough in some situations. You can
; get complete control over how something is formated by writing your
; own format function. The resulting format function can be installed
; as the G1GRIND-FN property of some atom, or can be SETQed as the value
; of one of the atoms G1format-dispatch, G1format-list, G1format-hunk,
; or G1format-atom. (G1format-dispatch is a somewhat special case.)
; Any format function must follow all of the requirements set forth
; above. There are several mechanisms for assisting you in writing
; format functions.
;
;In order to write your own format functions, you should study the format
; functions included in the Gprinter.
;
;The macro GMAKE-INVERT-QUOTE-FN constructs formatting functions which do
; simple read macro inversion. for example
; (Gmake-invert-quote-fn quote /')
; (which is part of the basic Gprint package) builds a formatting
; function which outputs '(quote foo)' as ''foo'. In order to see how
; this works, consider a more complete example:
; (Gmake-invert-quote-fn list /[ /])
; this would cause '(list a b c)' to print out as '[a b c]'. The macro
; produces the following formatting function:
;
(declare '| (defun (list Ggrind-fn) (temp item)
(setq G1open-del '/[ G1close-del '/])
(cond (G1format-list (funcall G1format-list temp (cdr item)))
((G1format-list temp (cdr item))))) |)
;
; This uses the variables G1OPEN-DEL and G1CLOSE-DEL in order to change
; the delimeters of the thing being formated and then formats the cdr of
; the thing. (if there is no close delimeter specified in the macro
; call (as in the QUOTE example), then a null close delimiter is
; assumed.) Note that the formatting function produced follows the
; convention that the variable G1FORAMT-LIST may contain a user
; redefinition of the default list formatting function.
;
;The function GMAKE-INVERT-QUOTE-FN2 is basically very similar except that it makes the basic
; assumption that the relavent value is the CDR instead of the CADR.
; as a result of this, there is no case corresponding to having both an open
; and a close delimiter. Rather you merely specify an atom which is printed
; before the CDR which is otherwise printed normally. for example:
; (Gmake-invert-quote-fn2 '|`-expander/|| '|`|) (which is part of the
; standard printer environment along with handling ',' ',@' and ',.')
; causes (|`-expander/|| a b c) to print out as `(a b c)
;The lsubr G1FORMAT-LSUBR is available in order to asisst you in writing
; format functions. Templates allow you to specify the fcodes to use.
; G1FORMAT-LSUBR allows you to additionally specify what objects to
; print and what order to print them in. This could be done by consing
; up a list of the things you wanted printed and then calling
; G1FORMAT-LIST. G1FORMAT-LSUBR allows you to get this effect without
; actually consing up the list. As such it is essentially used for
; efficiency. G1FORMAT-LSUBR could have been defined as:
; (defun G1format-lsubr nargs (G1format-list (arg 1) (listify (- 1 nargs))))
; the following example shows how G1FORMAT-LSUBR could be used to help
; write a nonstandard formater for hunks:
;
(declare '| (defun special-format-hunk (temp hunk)
(cond ((eq (hunksize hunk) 4)
(setq G1open-del '/@ G1close-del '/@)
((lambda (G1prinlevel G1prinlength)
(G1format-lsubr
'(1 (never) (never)) (maknum hunk) (cxr 3 hunk)))
4 4))
(t (G1format-hunk temp hunk)))) |)
;
; If you did a (setq G1format-hunk 'special-format-hunk) then whenever a
; hunk was going to be formated, the function SPECIAL-FORMAT-HUNK would
; be called. This function checks to see whether the hunk is a hunk4.
; If it is, then it prints out the maknum of the hunk and the cxr-3 of
; the hunk surrounded by @s. For example,
; (hunk 1 2 '(list zap) '(car foo)) would print out as
; '@123456 (list zap)@' if 123456 was the maknum of the hunk.
; Note that special-format-hunk binds G1prinlevel and
; G1prinlength in order to control the amount of abbreviation which will
; apply. If it hadn't bound them, then the abbreviation would have been
; a function of the depth of the hunk in the structure being printed.
; as it is it is always the same. If the hunk is not a hunk4 then the
; standard hunk formater is called in order to format the hunk.
;Using G1FORMAT-LSUBR implies that the standard formatting conventions
; described above will be used. If you want to do something complete
; original, you can write a format function which directly calls
; G1ENTER-OBJ. An example of the is (PROG GGRIND-FN) which is defined
; in the standard Gprinter. It is basically like G1FORMAT-LIST except
; that it prints the tags properly. This is also used to print DOs.
; There is also a little GGRIND-FN for DEFUN which makes it print out
; right in both 2 and 3 argument form.
;
;consider the following more detailed example.
(declare '(defun foo Ggrind-fn (unused-temp list)
(G1enter-obj 1 nil 'start)
(G1enter-format&obj 'never 0 (cadr list) 'prin1 nil)
(cond ((not (null (caddr list)))
(G1enter-format&obj 'never 0 '/- 'princ nil)
(G1enter-format&obj 'never (caddr list) 'prin1 nil)))
(G1enter-format&obj 'never 1 '/: 'princ nil)
(G1enter-format 'normal 0)
(G1format-dispatch nil (cadddr list))
(G1enter-format&obj 'never 0 '|| nil 'end)) )
;this directly calls G1enter-obj for five reasons: it uses non standard
; delimiters (in fact no open and close delimiters at all), it uses non-standard
; bcodes, it inserts certain internal delimeters (: and -), it does
; different things based on what the structure of the item is (ie
; whether or not the 3rd list ellement is nil), and it doesn't print the
; first item of the list at all, that just exists in order to get to the
; correct printout formatter. In GRIND mode,
; '(foo 1 2 3) would print as:
; '1-2: 3'
; '(foo 1 nil 3) would print as:
; '1: 3'
;IMPLEMENTATION NOTE ON SECTION 4,
;SPECIAL ATOMS USED BY THE FORMATTING FUNCTIONS:
;
;there are a set of special variables and properties which are used by the
; formatting functions either internally, or for control from the
; outside. this list describes EVERY special variable which is
; referenced by a format function, or is considered available to be
; looked at by a format function. (variables which are not actually
; used by the standard formaters are preceeded by a *.) These variables
; are divided into catagories even though there is really some logical overlap.
;
;variables passed down from G1PRINTER which describe how a thing will be formated.
; G1checkrecursion - (t/nil) if NIL, this enhibits the function G1rcheck from checking
; for circularity in objects being formated.
;*-G1prinlevel - (a non-negative number) The depth in a structure at which the formaters should
; abbreviate non-atomic substructures by inserting |#| in place of the
; substructure. This is not acutally looked at because the same information is
; indirectly encoded in the variable G1level (see below).
; G1prinlength - (a non-negative number) The maximum number of things to
; print out at any one level. if there are more that this many things at a
; given level, the |...| is printed out in place of the remainder. (actually if
; there is only 1 to many things, and the extra one is an atom, then the
; structure prints out unabbreviated.)
;*-G1prinstartline - (a non-negative number) This is the line number of the
; first line to print out. This is actually not used by the formaters, but it
; is available. (G1printout implements this abbreviation facility.)
;*-G1prinendline - (a non-negative number) This is the line number of the last
; line to print out. This is actually not used by the formaters, but it is
; available. (G1printout implements this abbreviation facility.)
;*-G1prinmode - (a template) This is the top level template to use for formatting the
; current thing. This is not actually used because it is passed as the
; first argument to the top level call of the format functions.
; G1princ-atoms - (t/nil) if non-NIL then individual atoms in the object to be
; formated. are marked so that they will be PRINCed instead of PRIN1ed.
; 1st argument to G1format-dispatch (and all other formatting functions) - (a
; template) this is a template which is used to guide the formatting of
; the object. The top level call of G1format-dispatch is passed the
; value of G1prinmode. Only G1format-dispatch can take a null template.
; 2nd argument to G1format-dispatch (and all other formatting functions) - (an
; arbitrary object) the object to be formated. G1formt-dispatch takes an
; object of any type. the others take restricted types as their names imply.
;variables which are set by the external environment and control the actions
; of the formaters.
; Ggrind-template PROPERTY - (a template) if an atom has a Ggrind-template
; property, then whenever G1format-dispatch is given a null template and
; a list whose car is that atom, then that template will be used to
; format the list.
; Gfn-grind-properties - (a list of property names) if an atom doesn't have a
; Ggrind-template property, but it does have one of the properties in
; this list, then whenever G1format-dispatch is given a null template
; and a list whose car is that atom, then a template which causes
; grinding in functional form will be used to format the list.
; G1default-symbol-car-grind-template - (a template) if G1format-dispatch is
; given a nil template and a list with an atomic car, and neither of the
; above two cases applies, then this template will be used to format the list.
; G1apply-template - (a template) this template is used in GRIND mode to
; format lists whose cars are lambda expressions.
; G1default-non-symbol-car-grind-template - (a template) if G1format-dispatch
; is given a nil template and a list with a non-atomic car which is not
; a lambda expression, then this template will be used to format the list
; Ggrind-fn PROPERTY - (a formatting function) if an atom has a Ggrind-fn
; property, then whenever G1format-dispatch is given a null template and
; a list whose car is that atom, then that formatting function will be used to
; format the list.
; G1format-dispatch - (a formatting function or nil) if non-nil this function
; is called whenever G1format-dispatch whould have been.
; G1format-list - (a formatting function or nil) if non-nil this function
; is called whenever G1format-list whould have been.
; G1format-hunk - (a formatting function or nil) if non-nil this function
; is called whenever G1format-hunk whould have been.
; G1format-atom - (a formatting function or nil) if non-nil this function
; is called whenever atoms are to be formated.
;variables which are used for internal communication between the formatting
; functions. All of these variables must be initialized before calling
; any format functions (this is done by G1format-init).
; G1parents - (a one dimensional array) This is used by G1rcheck in order to
; remember what cons cells have already been formated, so that it can
; detect circularity.
; G1rsize - (the length of the array in G1parents) This is used by G1rcheck
; in order to check that it is not overflowing the array G1parents. It
; automatically extends the array if it needs to.
; G1rindex - (a non-negative number less than G1rsize) This is the index of
; the first free slot in Gparents. It is incremented by G1rcheck
; whenever it adds a new entry into G1parents. It is the responcibility
; of the formatting functions which call G1rcheck to decrement the value
; of G1rindex. The easiest way to do this is for each format function to
; remember the value of G1rindex on entry, and restore this value on exit.
; (this works as long as the pattern of calls and returns of the format
; functions mirrors the tree like strucutre of the object being printed.)
; (initialized to zero)
; G1level - (a non-negative number) This counts down from G1prinlevel to
; zero. When it reaches zero, the format functions do prinlevel
; abbreviation. Each format function which corresponds to a level on
; nexting, should decrement G1level on entry, and increment it on exit.
; (initialized to G1prinlevel)
; G1open-del - (nil or a thing to be PRINCed as an open delimeter) If this is
; non-nil then it causes just one substructure to use it as the open
; delimiter. The one which uses it is the one corresponding to the
; temporally first call of a substructure formater after G1open-del is
; set. The substrucutres of this structure will use the normal
; delimiters. (initialized to NIL)
; G1close-del - (nil or a thing to be PRINCed as a close delimeter) this is
; just the same as G1open-del but for the close delimiter.
;
;variables which are used for communication between the formaters and
; G1ENTER-OBJ
; G1fcode - (one of {never normal tblock block always}) this says when to put
; a crlf before the next thing to print. it is initialized to 'never at
; the top level.
; G1bcode - (a non-negative number) this is how many blanks to print out
; after the next thing to print. it is initialized to zero at the top
; level. (note that G1FCODE and G1BCODE can be conveniently set by
; G1ENTER-FORMAT and G1ENTER-FORMAT&OBJ.)
; 1st arg of G1enter-obj - (an arbitrary object or if the 3rd arg is 'start
; then a number) this is the object to be printed at this point, it need
; not be an atom, though with the standard formaters it always is. if
; the second argument is NIL and the third argument is not 'start then
; the first argument is ignored, and there is no object to print.
; 2nd arg of G1enter-obj - (one of {prin1 princ nil}) the code that says how
; to print the object.
; 3rd arg of G1enter-obj - (one of {start end nil}) the code that indicates
; the beginning and end of substructures.
;SECTION 5, THE FUNCTIONS G1ENTER-OBJ AND G1PRINTOUT
;
;this is the nitty gritty which takes the formatting instructions produced by
; the formatting functions and dynamically decides how the output will
; actually look. It then does the actuall output. this is the part of
; the program which is somewhat convoluted and contorted in order to get
; efficiency. it embodies the basic ideas which make this printer so
; much faster than standard GRINDEF.
; It is not intended that the user modify these two functions.
; This is in contrast to the other parts of the system which are
; explicitly intended to be modifiable. This section is included to
; make the documentation complete, and to give a more complete
; understanding of how the Gprinter works.
;
;above, the actions of the formatting functions were described as creating a
; sequence of calls on G1ENTER-OBJ. (Note the macros G1ENTER-FORMAT and
; G1ENTER-FORMAT&OBJ which help in this.) G1ENTER-OBJ converts this sequence
; of calls into a static data structure which is used by G1printout in
; order to do the printing. The static data object is needed because
; G1ENTER-OBJ must do some look ahead in order to figure out some of the
; information it adds into the sequence of calls.
; The sequences of calls on G1enter-obj are designed to be easy to
; make, and to have little redundancy. The data structure is designed
; to have all of the information which G1printout needs made explicit.
; The data structure follows the same basic structure as the
; sequence of calls on G1enter-obj. It has one node of information for
; each call on G1enter-obj. at each node, it has all of the information
; passed to G1enter-obj plus several other pieces of information:
; 1. the length of the object (or entire substructure)
; 2. whether of not the substructure corresponding to a node contains
; an always code within it.
; 3. whether or not the object corresponding to this node is complete.
; I.E. in the case of substructures whether or not all of the calls
; on G1enter-obj corresponding to its interior have already been
; processed, and therefor whether the pieces of information described
; in 1, and 2 are really accurate yet. Until the item is complete these
; pieces of information are only partially true. (Note however, that
; they are monotonic. Ie they length can only increase as more is known,
; and 2 & 3 can only go from false to true.)
; Note that each of these additional pieces of information is summary
; information about a number of nodes which combine to form a
; substructure. A number of nodes must be saved up in order to complete
; the calculation associated with a given node. (in the limit this
; implies that the information (for example the length) associated with
; the very first node (which is a substructure starting node for the
; whole thing to be printed) cannot be complete until all of the nodes
; have been created.)
; This would lead to a large use of storage if it weren't for one
; very important fact. The function G1PRINTOUT is often able to decide
; what it will do with a node before it has complete information about
; the node. This is due to the monitonic nature of these fields. For
; example, G1ENTER-OBJ continually updates the length fields as new
; nodes are created. G1PRINTOUT can decide that a given substructure is
; too long to fit on one line as soon as its length gets longer than the
; line length. It does not have to wait until it knows what the actual
; complete length is. this allows early nodes to be processed even
; before they are complete constructed. (It turns out that whether
; something is too long for a line is the basic thing which G1PRINTOUT
; needs to know, and as a result the system only needs to have at one time
; the nodes which correspond to roughly one line of output. This is
; true even if the thing printing out ends up taking up hundreds of lines)
;An important efficiency comes from the fact that G1PRINTOUT processes nodes
; in the data structure in a purely first in first out order. this
; allows them to be stored in a queue. as each node is created it is
; added into the queue, and G1ENTER-OBJ updates the information
; associated with the other nodes still in the queue. when one
; is processed it is dropped form the queue, and G1ENTER-OBJ no longer
; tries to compute updated information for it.
; A very big savings comes from the fact that this queue is
; implemented in arrays in such a way that no CONSing is done. This
; prevents the Gprinter from creating garbage collections. These arrays
; are managable in size beacuse the number of nodes that must be
; remembered at once is a function of the line length and NOT of the size
; of the thing being printed (as discussed above).
; (this queue is not implement as a ring buffer wrapping around in
; the array, but rather by just shifting things over in the array when
; the queue strikes one end. This at first appears time inefficient,
; however, since the queue never gets very long, the time lost in
; shifting is more than made up for by the time saved in testing whether
; the queue is empty, and poping ellements off of the queue.)
;
;For storage efficiency, the information associated with each node is crammed
; into three cells:
; 1. (referred to as LENGTH) holds a number which is the length of the
; object associated with the node.
; 2. (referred to as OBJECT) holds the object or indentation code
; associated with the node.
; 3. (referred to as FLAGS) holds the blank code and all of the binary
; flags packed together as bits. a set of macros are used to set and
; check these bits.
;
;The function G1SET-UP-MACROS if exicuted creates all of the macros needed for
; in compilation or running these functions uncompiled. Otherwise, the
; macros are not defined when you fasload in Gprint. A function DECODE
; is also defined by G1SET-UP-MACROS. This function is a debugging aid.
; It decodes the bits in FLAGS into a more readable form.
; There are two basic macros which get defined. FLAGS is a macro
; which builts up FLAGS entries. It takes numbers, things which
; evaluate to numbers and quoted keywords from the list
; {always normal block tblock never princ prin1 list-start list-end
; complete inner-always}.
; It creates code which builds a FLAGS entry. for example:
; (flags 1 'never 'list-start (foo))
; creates a FLAGS entry which has a blank code of 1, a format code of
; 'never, is the starting node for a substructure, and which also has
; all of the bits set corresponding to the FLAG returned by (foo).
; A set of macros is produced for querying these bits. the set
; {always? normal? block? tblock? never? princ? prin1? list-start? list-end?
; complete? inner-always?} test for the presence of the corresponding
; flags. The macro BCODE returns the number corresponding to the blank
; code of a FLAGS entry.
;G1enter-obj performs several tasks:
; 1. It combines the variables G1FCODE G1BCODE, and its second and third
; arguments into a FLAGS entry. (Note that these variables can be
; conveniently set by G1ENTER-FORMAT and G1ENTER-FORMAT&OBJ.)
; 2. As part of this it takes the bcode associated with a list-start node
; and puts it on the last node in the substructure. this is done
; because it is more logical to state the bcode when starting the
; structure, but more conventient for G1PRINTOUT to have it at the end
; (which is after all where the blanks get printed). In order to do
; this G1ENTER-OBJ uses a stack implemented in a vector G1BCODESTACK and
; using a pointer G1SUPPTR. The stack is needed in order to remember
; the bcode from the time it is first available until the time it is
; needed.
; 3. It computes the length of each atomic node (those which aren't
; list-start nodes) and puts that as the length of the node and adds it
; into the length of all of the list start nodes which are its superiors
; (except those which have already been taken off the queue). The
; list-start nodes start out with length zero. The length of an atomic
; node is the bcode plus the flatsize (or flatc) of the object to print
; (if there is one). The vector G1SUPSTACK is used to keep a stack of
; the superiors of the current node. the stack contains numbers which
; are the differences between the positions in the queue of succeeding
; superiors. differences are used because they remain correct when the
; queue is shifted over. the pointer G1SUPPTR is used as the stack
; pointer since G1SUPSTACK and G1BCODESTACK go up and down in synchrony.
; 4. If any node has an ALWAYS flag, then G1ENTER-OBJ sets the INNER-ALWAYS
; flag on in each superior.
; 5. G1ENTER-OBJ sets the COMPLETE flag on in each atomic node, and with
; each list-end node, it marks the corresponding list-start, complete.
; 6. Internally it maintains G1SUPSTACK and G1BCODESTACK for its own use.
; this amounts to pushing each list-start node and doing a pop for each
; list-end node. In addition G1ENTER-OBJ extends the vectors if they
; ever prove to be too short. G1SUPSIZE holds their length for easy
; reference.
; 7. it enters each of these objects into the queue. the queue is
; implemented by three vectors: G1OBJ, G1FLAG and G1LENGTH and two
; pointers: G1INPTR which points to the insertion point and G1PP which
; points to the removal point (the head of the queue). These vectors
; are extended if they prove too small. the variable G1SIZE holds the
; length of these vectors for easy reference.
; 8. if the variable G1EXPLODING is non-nil then instead of queueing up the
; nodes, G1ENTER-OBJ just NCONCs up the EXPLODEs of the objects in the
; atom nodes in the variable G1EXPLODE-RESULT. NRECONC is used, so that
; G1EXPLODE-RESULT can simply be NREVERSed in order to get the result.
; 9. if G1EXPLODING is nil then G1ENTER-OBJ calls G1PRINTOUT each time a
; new node is added in order to see whether it has enough information to
; do something.
;the following example shows the static data structure built up corresponding
; to the example from section 2:
(declare '|'(list (cons var1 var2) var3 var4)' leads too:
fcode bcode obj pcode lcode length inner-a complete
1 'never ← 6 nil 'start 33 nil t
2 'never 0 '/( 'princ nil 1 nil t
3 'never 1 'list 'prin1 nil 5 nil t
4 'never ← 6 nil 'start 17 nil t
5 'never 0 '/( 'princ nil 1 nil t
6 'never 1 'cons 'prin1 nil 5 nil t
7 'never 1 'var1 'prin1 nil 5 nil t
8 'normal 1 'var2 'prin1 nil 4 nil t
9 'never 1 '/) 'princ 'end 2 nil t
10 'normal 1 'var3 'prin1 nil 5 nil t
11 'normal 0 'var4 'prin1 nil 4 nil t
12 'never 0 '/) 'princ 'end 1 nil t |)
;this is as you would see it left in memory after printout was complete. all
; of the complete bits have been turned on, there are no inner-always,
; the lengths have been computed, the bcodes have been moved from the
; list-start nodes to the corresponding list-end nodes. The section
; above which discusses calls on G1ENTER-OBJ discusses how the above
; sequence would be interpreted in order to print the list out.
;The function G1PRINTOUT acts like an interpreter for the data structure built
; up by G1ENTER-OBJ. Each time it is called it looks at the first
; element in the queue and decides whether or not it can do something
; with it. If it can do something it loops back and calls itself
; again. If not it just exits.
; 1. it first checks to see if the queue is empty, if so, it just exits.
; 2. It then checks to see if it is possible that it might have to tab in
; front of the next node (ie if it has a TBLOCK fcode and is complete).
; If this is the case, and if it hasn't already figured out what the size of
; tabs will be (the variable G1TABSIZE is 1) then It figures out what the size
; of tabs will be. It does this by looking at the length of the current node
; and the following nodes at the same level. It takes the max of all their
; lengths. However, it realizes that it may not have seen all of the subnodes
; which are supposed to be printed in columns and therefor this maximum may not
; be long enough to insure that all of the nodes will line up nicely when
; printed out. In order to make a more conservative estimate of the spacing
; required, it first raises its estimate by 20%, and then rounds it
; up to the largest integer which divides the available line length the same
; number of times. To do this it uses the properties of integer arithmitic and
; the expression:
; x = (// linelength (// linelength x))
; For example if the maximum node in view is 11 and the available line
; length is 62 (for example, the line length is 95 and this substructure
; starts in column 33). first the max would be increased by 20% to 13 and then it
; would be increased to 15 since 13 goes into 62 4 times, and 15 is the
; largest integer which goes into 62 4 times.
; Having computed the tab size, G1PRINTOUT then computes an offset
; in the variable G1TABOFFSET. this is done because the space remaining
; on the line may not be a multiple of the tab size. (In the example
; above the offset is 2.) How far to tab in a given situation is
; computed by the expression:
; (\ (- space-remaining G1taboffset) G1tabsize)
; (there is a bug in this if the space remaining ever gets less than
; G1TABOFFSET. In this case, the remainder function has a negative first
; argument and doesn't do what you would like. To fix this the offset
; stored in G1TABOFFSET is actually (- offset G1TABSIZE) this is just
; the same from the point of view of modular arithmetic and has the
; virtue that it is always negative.)
; 3. next G1PRINTOUT checks to see whether it needs to insert a crlf at the
; current point. In doing this it checks whether the last thing is did
; was to put out a crlf. if so, then it never puts out another one.
; then if the next thing needs to be tabbed in front, it checks to see
; whether enough spaces have been put out. Finally it looks at the
; fcode and sees whether it implies that a crlf whould be inserted. (See
; above for a deiscussion for what the fcodes mean.)
; 4. if a crlf is needed, then it is put out and blanks are printed in
; order to space over to the correct indentation column. the
; indentation codes in the calls to G1ENTER-OBJ are used in order to
; know what column to tab too. the indentation columns are remembered in
; a stack implemented by a vector in G1INDSTACK and the pointer
; G1INDPTR. (See below for how the indentation points are calculated.)
; This section implements G1prinstartline-G1prinendline
; abbreviation. a variable G1printing? is used as a flag which controls
; whether any actual output is ever done. Each time a crlf is to be
; performed G1PRINTOUT checks to see whether the state of this flag
; should be changed. if G1prinendline is reached, then G1PRINTOUT does
; a throw in order to abort the Gprinting.
; 5. Now G1PRINTOUT knows that if a crlf is needed before the next thing,
; it has already been put out. it now looks at the next thing to be
; printed out. there are three cases:
; 6. the next item is a substructure whose length as currently computed is
; already too long to fit in the space remaining on this line. In this
; case, G1PRINTOUT looks inside this structure in order to print it on
; more than one line. to do this, it simply moves over the header node
; and computes the new indentation column. the new indentation is
; computed by adding the indentaion count in the header cell to the
; current column possition. if the resulting indentation is less than
; the initial starting column position (kept in the variable G1CP) then
; it is increased to that. this is waht prevents the Gprinter from ever
; printing to the left of where it starts. if it is greater than the value of
; G1MAXINDENTLEN (which is initialized to 80% of the available line length) then
; it is reduced by 60% of the available line length. this keeps output
; from getting so pushed up against the left margin that there isn't enough
; room to print the individual atoms in the structure. an abrubt
; change in indentation is produced which tends to be rather ugly, but
; which is clearly understandable and saves the G1printer from disaster.
; The new indentation level is pushed onto the stack G1INDSTACK.
; (G1PRINTOUT does not have to check for overflow in this vector,
; because G1ENTER-OBJ extends it to be as long as G1SUPSTACK. The
; latter is as long as the maximum number of levels in the structure
; being printed. as a result G1INDSTACK can't overflow even if
; G1PRINTOUT has to look inside the deapest structure in the thing being
; printed.)
; In addition G1TABSIZE is set to 1 which indicates that it is
; unitialized. It will be recaluclated for this new level if needed.
; 7. alternatively, the next node may not be too long to fit and may be
; complete. if this is the case then it is printed out. G1PRINTOUT
; counts header nodes and LIST-END nodes in order to see when it has
; printed out all of the things associated with the initial node. If
; the first node encountered by G1PRINTOUT is a LIST-END node then
; G1PRINTOUT prints it out and pops up a level in the structure being
; printed. when it does this, it sets G1TABSIZE to 64000. which has the
; effect of preventing continued tabbing at the level popped back to.
; Logically G1PRINTOUT should keep a stack of tab sizes, so that it
; could continue tabing when it pops back out of a substructure.
; However, it was decided that if one of the substructures in a
; structure being printed with tabbing takes more than one line, then
; tabbing should not continue at that level. This was done because
; experimentation showed that continued tabbing made it harder to
; understand what was being Gprinted.
; 8. often neither 6 or 7 is true, in that case, G1PRINTOUT just does
; nothing and returns to G1ENTER-OBJ in order to get more information.
; 9. if either 6 or 7 was true then G1PRINTOUT loops back to the top in
; order to see whether it can do anything more.
;IMPLEMENTATION NOTE ON LEVEL 5
;SPECIAL VARIABLES USED BY G1ENTER-OBJ AND G1PRINTOUT
;
;a large number of these variables (particularly the ones which are internal
; to theis part of the package) are initialized by the function G1FORMAT-INIT.
;
;variables which are used for communication between the formaters and
; G1ENTER-OBJ:
; G1fcode - (one of {never normal tblock block always}) this says when to put
; a crlf before the next thing to print. it is initialized to 'never at
; the top level.
; G1bcode - (a non-negative number) this is how many blanks to print out
; after the next thing to print. it is initialized to zero at the top
; level. (note that G1FCODE and G1BCODE can be conveniently set by
; G1ENTER-FORMAT and G1ENTER-FORMAT&OBJ.)
; 1st arg of G1enter-obj - (an arbitrary object or if the 3rd arg is 'start
; then a number) this is the object to be printed at this point, it need
; not be an atom, though with the standard formaters it always is. if
; the second argument is NIL and the third argument is not 'start then
; the first argument is ignored, and there is no object to print.
; 2nd arg of G1enter-obj - (one of {prin1 princ nil}) the code that says how
; to print the object.
; 3rd arg of G1enter-obj - (one of {start end nil}) the code that indicates
; the beginning and end of substructures.
;
;Variables which are used to communicate between G1PRINTER and G1ENTER-OBJ:
; G1exploding (t/nil) if T then G1PRINTOUT is not actually called, and the
; EXPLODEs of the nodes is consed up and returned instead.
; G1explode-result (a list of characters) if Gexploding, this is used to
; accumulate the nreverse of the result in.
;
;Variables which are used to communicate between G1PRINTER and G1PRINTOUT:
; G1prinendline (a non-negative number) this says what line to stop printing
; on. when this line is reached a throw is done to terminate Gprinting.
; G1prinstartline (a non-negative number) this says what line to start
; printing on. Until this line is reached, nothing is actually printed out.
; G1cp (a non-negative number) this is the column position where Gprinted was
; initiated. GRINTOUT takes pains not to print ot the left of this
; point. it is treated as the defacto zero point for the left margin.
; this is initialized by G1FORMAT-INIT to (CHARPOS G1MAINFILE).
; G1linelen (a non-negative number) this is (- (LINEL G1MAINFILE) 5) the -5 is
; done in order to make closing parentheses come out in the right place a
; higher percentage of the time. this is used to figure out how much
; space is left on the current line being printed on.
; G1maxindentlen (a non-negative number) this is point 80% of the way from
; G1CP to G1LINELEN and is used to limit the total amount of indentation allowed.
; G1files (a list of files) this is used as an argument to PRINC PRIN1 TERPRI
; and TYO in order ot control where the output goes to.
;
;Variables used by G1ENTER-OBJ to communicate with itself:
; G1bcodestack (a vector of fixnums) this holds the bcodes which are specified
; at the start of substructures until they are used at the end of the substructure.
; G1supstack (a vector of fixnums) this holds differences which can be used to
; find the nodes which are the superiors of the current node.
; G1supptr (a fixnum pointer into the above two vectors) this is used to make
; a stack out of the above.
; G1supsize (the size of the above two vectors) this holds the size of the
; above vectors and G1indstack below (which are automatically extended if need be).
;
;Variables used for communication between G1ENTER-OBJ and G1PRINTOUT:
; G1obj (a vector of objects) the object at a node
; G1flag (a vector of flag bits crushed into fixnums) the flag bits for a node.
; G1length (a vector of fixnums)the length of each node.
; as discussed at length above, these three vectors form a queue holding
; the information at each node of the intermediate structure built up by
; G1ENTER-OBJ.
; G1inptr (a pointer into the above three vectors) the insertion point in the
; above queues.
; G1pp (a pointer into the above three vectors) the removal point in the above
; queues.
; G1size (the size of the above three vectors) this holds the size of the
; above vectors (which are automatically extended if need be).
;
;Variables used by G1PRINTOUT to communicate with itself:
; G1cline (a non-negative number) this is the relative line number of the
; place where G1PRINTOUT is currently printing. this is what is compared
; with G1prinendline and G1prinstartline.
; G1freelen (a number) this is the amount of free space left at the end of the
; current line. the current charpos on that line is (- G1linelen G1freelen).
; G1pending (a non-negative number) this is the number of blanks which should
; be printed before the next thing. G1PRINTOUT never prints any blanks
; until it absolutely has to, rather it just increments G1PENDING. this
; allows it to simply avoid printing blanks at the end of a line.
; G1tabsize (a non-negative number) this is the current size for tabbing (see
; the discussion above). The value 1 indicates that the correct tab size
; has not yet been calculated.
; G1taboffset (a negative number) This is used in conjunction with G1TABSIZE
; (see the discussion above).
; G1atstart? (t/nil) this flag is used by G1PRINTOUT in order to quichly check
; whether or not it is at the start of a line. ie whether th e last
; thing it did was to do a crlf or not.
; G1wentup? (t/nil) this is T if the last thing G1PRINTOUT did was to pop up
; out of a lower structure. this is used in conjunction with BLOCK and
; TBLOCK modes.
; G1printing? (t/nil) this is nil when G1cline is less that G1prinstartline
; and therefor actual printout is being supressed.
; G1indstack (a vector of numbers) this is a stack which is used to keep the
; indentation points associated wiht the different levels in the
; structure being printed. each indentation is greater than or equal to
; G1cp and less than of equal to G1maxindentlen.
; G1indptr (a pointer into the above vector) this is used to implement a
; stack in G1indstack.
;these are all declarations and macro definitions
(declare (fasload util fasl dsk dick) (u1setupreader)
(fixnum i j k n length end rindex max default-bcode bcode space level flags)
;system special variables which are looked at, never bound, and never assigned to
;(except that some of them may be given initial values at load time if they are unbound)
;most of these are used in order for the user to comunicate with the printer.
(special Gcheckrecursion prinlevel prinlength prinmode prinendline
prinstartline ↑r ↑w outfiles grindef grindproperties Gfn-grind-properties
G1default-symbol-car-grind-template G1default-non-symbol-car-grind-template
tyo G1format-dispatch G1format-list G1format-atom G1format-hunk grind-macroexpanded)
;special variables which are used by the system to communicate with itself. they
;are rebound in order to save a state of the system, and are set up by G1format-init
;these should not be changed by the user unless he really knows what he is doing.
(special G1prinlevel G1prinlength G1prinendline G1prinstartline
G1cp G1linelen G1maxindentlen G1cline G1freelen G1pending G1tabsize
G1taboffset G1inptr G1pp G1supptr G1indptr G1size G1supsize G1rsize
G1prinmode G1checkrecursion G1mainfile G1truncated G1files
G1atstart? G1wentup? G1printing? G1obj G1flag G1length G1supstack
G1indstack G1parents G1nowprinting G1fcode G1bcode G1bcodestack
G1level G1rindex G1open-del G1close-del G1princ-atoms G1print-like
G1exploding G1explode-result)
;special variables which are used to hold system constants (they should never be modified)
(special G1miser-template G1block-template G1crush-template G1fn-template
G11level-block-template G1defun1-template
G1defun2-template G11level-tblock-template
G1apply-template G11level-miser-template G1tblock-template)
(*lexpr Gprin1 Gprint prinl prinl1))
(declare (@define deffn))
;this file makes heavy use of the macros in the file util > dsk dick. for those who
;do not like to read macros like these, a completely macro expanded version of Gprint
;is included at the end of the file. that version contains no macro calls,
;and is guarrenteed to be accurate (in fact, the fasl file is actually a compilation of the
;the macro expanded version). As long as I maintain this file I will work with the
;macro version and keep the expanded version correct.
;these macros are here in order to satisfy the compiler,
;they logically belong with G1enter-obj
(deffn G1enter-format macro keep displace [← f b]
`(setq G1fcode ,f G1bcode ,b))
(deffn G1enter-format&obj macro keep displace [← f b o p l]
`(progn (G1enter-format ,f ,b)
(G1enter-obj ,o ,p ,l)))
;this is used to construct a fn G1set-up-macros which can be run at any time
;in order to define all of the macros which are needed for any of the functions
;below can be run interpretively. This gives you access to the macros without
;having them always defined.
(decl
(deffn build-G1set-up-ms macro []
(let ((Gencodings '((always 64.) ; 000 100
(normal 128.) ; 000 200
(block 256.) ; 000 400
(never 512.) ; 001 000
(tblock 1024.) ; 002 000
(princ 2048.) ; 004 000
(prin1 4096.) ; 010 000
(list-start 8192.) ; 020 000
(list-end 16384.) ; 040 000
(complete 32768.) ; 100 000
(inner-always 65536.)))) ; 200 000
['deffn 'G1set-up-macros '[]
!(over '((G1obj nil) (G1flag fixnum) (G1length fixnum) (G1supstack fixnum)
(G1indstack fixnum) (G1parents nil) (G1bcodestack fixnum))
-> [atom type] nconc
`((deffn ,atom macro displace [!from]
`(arraycall ,',type ,.(copy from)))
(deffn ,atom u1<- [to]
`((store ,to u1f) nil))))
'(deffn call macro displace [← fn ! args]
`(if ,fn (funcall ,fn ,.args)
el (,fn ,.args)))
'(deffn bcode macro displace [← x]
`(boole 1. 63. ,x))
!(over Gencodings -> [name code]
list `(deffn ,(catenate name '?) macro displace [← x]
`(not (zerop (boole 1. ,',code ,x)))))
;there are three different kinds of arguments to FLAGS. literal numbers, something that
;evaluates to a number, and quoted atoms from the list of flag names in Gencodings
(subst Gencodings 'encodings
'(deffn flags macro displace [← ! args]
(begin (sum <- 0
body <- (over args -> arg
nconc (if (numberp arg)
(<- sum (+ sum arg))
nil
ef (or (atom arg) (not (eq (car arg) 'quote)))
[arg]
el;(eq (car arg) 'quote)
(let ((val (cadr (assq (cadr arg) 'encodings))))
(if (null val) (error '|bad code to FLAGs| args))
(<- sum (+ sum val)))
nil)))
(if (not (zerop sum)) (<- body [sum ! body]))
(if (null body) ''0
ef (null (cdr body)) ['progn ! body]
el ['+ ! body]))))
(subst Gencodings 'encodings
'(deffn decode [x]
[(bcode x)
!(over 'encodings -> [name code]
select (not (zerop (boole 1. code x)))
list name)]))])))
(decl-double (build-G1set-up-ms))
(decl (G1set-up-macros))
;the basic printer produces output under the control of a template.
;(yet another simple programming language)
;the template conforms to the following grammer:
;
; template := explicit-temp v NIL
; explicit-temp := ( indent-count item-temp*n )
; indent-count := number v NIL
; item-temp := ( {NEVER v ALWAYS v NORMAL v BLOCK v TBLOCK} . template )
;
;if a template is NIL then the printer looks at the item to be printed in order to figure
;out what the template should be. if an indent count is NIL then (+ 2 (flatsize of the head of
;the list being printed)) is used as the indentation (this is functional form indentation).
;
;the printer carcdrs down the template and the item being printed in order to decide
;what format codes and indentation codes to use at each point.
;It has internal conventions for what the other flag fields will be.
;
;the average template is a very circular structure so that it can work on structures of
;arbitrary depth and circularity. the following function is included in order to make it
;easier to construct these circular structures. the argument to Gmake-template is a list
;which may contain elements of the form (↑ . n) (as cars or cdrs). each of these is RPLACed
;by its nth parent in the list structure. for example:
;(SETQ X (GMAKE-TEMPLATE '(FOO (↑ . 2) BAR . (↑ . 1))))
;would produce an x such that (eq x (cadr x)) and (eq (cddr x) (cdddr x))
;x has the form (foo (foo (foo ...) ...) bar bar bar ...)
;note that Gprint whould print x out as (foo ↑2 bar ↑1) if Gcheckrecursion was non-null.
;
;note that this does not destroy its argument, and works even if its argument is circular.
(deffn Gmake-template [pattern]
(Gmake-template1 pattern nil nil))
(deffn Gmake-template1 [pattern oldbacklist newbacklist]
(if (atom pattern) pattern
ef (memq pattern oldbacklist)
(over oldbacklist until nil -> old
over newbacklist until nil -> new
(if (eq old pattern) (return new)))
ef (eq (car pattern) '↑)
(over newbacklist until nil -> new
over icount <- (1- (cdr pattern)) by (1- icount) until nil
(if (zerop icount) (return new)))
el (let ((newcons (ncons nil)))
(pushonto oldbacklist pattern)
(pushonto newbacklist newcons)
(rplaca newcons (Gmake-template1 (car pattern) oldbacklist newbacklist))
(rplacd newcons (Gmake-template1 (cdr pattern) oldbacklist newbacklist))
newcons)))
;these are the basic templates which are used to implement the five basic printing
;modes MISER, CRUSH, BLOCK, TBLOCK, and the functional and block forms of GRIND.
(deffn G1set-up-templates []
(<- G1miser-template
(Gmake-template '(1 (never . (↑ . 3)) (normal . (↑ . 4)) . (↑ . 1)))
G1crush-template
(Gmake-template '(-900 (never . (↑ . 3)) . (↑ . 1)))
G1block-template
(Gmake-template '(1 (never . (↑ . 3)) (block . (↑ . 4)) . (↑ . 1)))
G1tblock-template
(Gmake-template '(1 (never . (↑ . 3)) (tblock . (↑ . 4)) . (↑ . 1)))
G1fn-template
(Gmake-template '(nil (never) (never) (normal) . (↑ . 1)))
G11level-miser-template
(Gmake-template '(1 (never) (normal) . (↑ . 1)))
G11level-block-template
(Gmake-template '(1 (block) . (↑ . 1)))
G11level-tblock-template
(Gmake-template '(1 (tblock) . (↑ . 1)))
G1default-symbol-car-grind-template G1fn-template
G1default-non-symbol-car-grind-template G11level-miser-template
(get 'lambda 'Ggrind-template)
(Gmake-template '(2 (never) (never . (1 (block) . (↑ . 1)))
(normal) . (↑ . 1)))
G1apply-template
(Gmake-template '(1 (never) (block) . (↑ . 1)))
(get 'setq 'Ggrind-template)
(Gmake-template '(nil (never) (never) (block) (always) (block) . (↑ . 2)))
(get 'cond 'Ggrind-template)
(Gmake-template '(nil (never) (never . (1 (never) (normal) . (↑ . 1)))
(always . (1 (never) (normal) . (↑ . 1)))
. (↑ . 1)))
G1defun1-template
(Gmake-template '(2 (never) (never . (1 (never) (normal) . (↑ . 1)))
(never) (normal) . (↑ . 1)))
G1defun2-template
(Gmake-template '(2 (never) (never) (never) (never) (normal) . (↑ . 1)))))
(G1set-up-templates)
;this checks that the special variables which control formatting are bound
;(the rest of the system assumes that they are bound) It gives them default
;values if they were not bound
(deffn G1set-up-globals []
(<- G1truncated nil)
(over '((prinlevel nil)
(prinlength nil)
(prinmode grind)
(prinstartline nil)
(prinendline nil)
(Gcheckrecursion nil)
(Gfn-grind-properties (expr fexpr macro subr lsubr fsubr array autoload))
(grindproperties (expr fexpr macro))
(grindef nil)
(G1format-dispatch nil)
(G1format-list nil)
(G1format-hunk nil)
(G1format-atom nil)
(G1nowprinting nil)
(G1size nil))
-> [atom val]
(if (not (boundp atom))
(set atom val))))
(G1set-up-globals)
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;this is available for setting up the suggested printing environment. it MUST
;BE CALLED BY THE USER if you want it to happen
(deffn G1set-up-printer []
(sstatus ttyint 19. 'Gprintabort) ;↑S stops printing
(sstatus ttyint 3. 'Gcontinue) ;↑C makes it continue on
(endpagefn tyo 'G1endpagefn) ;needed by ↑C
(setq prin1 'Gprin1)) ;makes Gprin1 default printer
;this is available to free up almost all of the space taken up by the Gprinter.
;this really isn't very much space (binary program or otherwise)
(deffn G1rem-printer []
(if (eq (status ttyint 19.) 'Gprintabort) (sstatus ttyint 19. nil))
(if (eq (status ttyint 3.) 'Gcontinue) (sstatus ttyint 3. nil))
(if (eq (endpagefn tyo) 'G1endpagefn) (endpagefn tyo '+internal-tty-endpagefn))
(setq prin1 nil)
(over '((macro G1enter-format)(macro G1enter-format&obj)
(subr Gmake-template)(subr Gmake-template1)
(subr G1set-up-templates)(subr G1set-up-globals)
(subr G1set-up-printer)(subr G1rem-printer)
(lsubr Gprin1)(lsubr Gprinc)(lsubr Gprint)
(lsubr Gprinl1)(lsubr Gprinlc)(lsubr Gprinl)
(subr Gexplode)(subr Gexplodec)(lsubr Gexplodel)
(fsubr grindef)(subr G1printabort)(subr Gcontinue)
(subr G1endpage-fn)(subr G1printer)(subr G1format-init)
(subr G1format-dispatch)(subr G1rcheck)(subr G1format-list)
(lsubr G1format-lsubr)(subr G1format-hunk)
(macro Gmake-invert-quote-fn)(macro Gmake-invert-quote-fn2)
(Ggrind-fn quote) (Ggrind-fn defun)(Ggrind-fn prog)(Ggrind-fn do)
(Ggrind-fn macroexpanded)
(subr G1set-up-macros)(subr G1enter-obj)(subr G1printout))
(remprop (cdr ←) (car ←)))
(over '(G1obj G1flag G1length G1supstack G1bcodestack G1indstack G1parents G1pobj)
(makunbound ←)))
;the following are the main user functions for calling the Gprinter
;they are all in the form of a call on G1printer and they are all lsubrs
(defun Gprin1 nargs (G1printer 0. (arg 1) (listify (- 1 nargs))))
(defun Gprinc nargs (G1printer 1. (arg 1) (listify (- 1 nargs))))
(defun Gprint nargs (G1printer 2. (arg 1) (listify (- 1 nargs))))
(defun prinl1 nargs (G1printer 4. (arg 1) (listify (- 1 nargs))))
(defun prinlc nargs (G1printer 5. (arg 1) (listify (- 1 nargs))))
(defun prinl nargs (G1printer 6. (arg 1) (listify (- 1 nargs))))
(defun Gexplode (obj) (G1printer 8. obj nil))
(defun Gexplodec (obj) (G1printer 9. obj nil))
(defun Gexplodel nargs (G1printer 14. (arg 1) (listify (- 1 nargs))))
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;this is a rewritten version of grindef which calls prinl. it is intended to be
;exactly compatable with the old grindef as far as arguments etc.
;the variable GRINDPROPERTIES holds the default properties which will be printed
;out. additional properties can be specyfied as the first arg of GRINDEF. the printout
;format is of course a bit different as is the way you specify grind functions.
(deffn grindef fexpr [!arg]
(begin ([← (not (atom ←)) = props :!← !atoms]
<- (if arg (<- grindef arg) el grindef)
selectedprops <- [!! props ! grindproperties])
(over atoms -> atom
(and (status feature trace) (memq atom (trace))) -> traced
(over [ind prop ! rest] <- (plist atom) by rest until (null ind)
select (and (if (and traced (memq ind '(expr fexpr macro)))
(<- traced nil)
(if (memq ind selectedprops)
(terpri) (princ '|;traced|))
nil
el t)
(memq ind selectedprops))
(if (and (not (atom prop)) (eq (car prop) 'lambda))
(prinl ['defun
! (if (eq ind 'expr) [atom]
ef (memq ind '(fexpr macro)) [atom ind]
el [[atom ind]])
! (cdr prop)]
'grind)
el (prinl ['defprop atom prop ind] 'grind)))))
'||)
;this should be put on an interrupt character i.e. (sstatus ttyint 19. 'Gprintabort)
;it enables you to stop printing in the middle of something.
(deffn Gprintabort [unused-f unused-ch]
(nointerrupt nil)
(tyi tyi)
(if G1nowprinting (errset (throw '|aborted| G1printabort))))
;this allows you to continue output which was truncated because
;it was too many lines long. it is only really intended to work with output to the tty.
;this should be put on an interrupt character ie (sstatus ttyint 3. 'Gcontinue)
(declare ((lambda (obarray) (remprop (intern 'cursorpos) (intern 'acs))) sobarray))
;due to changes in cursorpos fn code.
(deffn Gcontinue [unused-f unused-ch]
(nointerrupt nil)
(tyi tyi)
(if G1truncated
(begin ([c1truncatepos c1cp c1mainfile c1code c1obj
[← ← ← ← ← c1files] = c1params] <- G1truncated
on-same-line <- (= (car c1truncatepos) (car (cursorpos c1mainfile))))
(cursorpos (car c1truncatepos) (cdr c1truncatepos) c1mainfile)
(cursorpos 'l c1mainfile)
(if on-same-line (terpri c1files) el (terpri c1mainfile))
(over i <- c1cp by (1- i) until (zerop i) (tyo 32. c1mainfile))
(G1printer c1code
;this terrible cludge is in here to force c1obj into a register so that the
;call on MUNKAM will compile correctly!!!!!!
((lambda (foo) (munkam (+ foo 0))) c1obj)
c1params)
(if (not on-same-line) (terpri G1files))))
'||)
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;this is a new endpage function which must be used if Gcontinue is used because
;for some reason the system endpagefn will not do mores during the printout initiated by
;Gcontinue.
(deffn G1endpagefn [tty]
(nointerrupt nil) (cursorpos 'z tty) (cursorpos 'l tty)
(princ '|**more**| tty)
(let ((echofiles nil)) (tyi))
(cursorpos 'z tty) (cursorpos 'l tty) (cursorpos 'top tty) (cursorpos 'l tty))
;this is the main entry function into the internals of the printer.
;it checks to see if the printer is being reenterd and if so rebinds all of the critical
;globals so that the old invocation will be protected. then it sets up the initial
;values of all of the globals and fires up the format functions.
(deffn G1printer [code obj inits]
;if reentering printer rebind everything and recurse.
(if G1nowprinting
(let (G1nowprinting G1obj G1flag G1length G1supstack G1indstack G1parents
G1size G1supsize G1rsize G1prinlevel G1prinlength G1prinendline
G1prinstartline G1cp G1linelen G1maxindentlen G1cline G1freelen
G1pending G1tabsize G1taboffset G1inptr G1pp G1supptr G1indptr G1prinmode
G1checkrecursion G1mainfile G1files G1atstart? G1wentup?
G1printing? G1fcode G1bcode G1bcodestack G1open-del G1close-del G1level
G1rindex G1princ-atoms G1print-like G1exploding G1explode-result)
(G1printer code obj inits))
;decode arguments and set up format control variables.
el (begin (G1nowprinting <- t)
(<- G1princ-atoms (not (zerop (boole 1. 1. code)))
G1print-like (not (zerop (boole 1. 2. code)))
G1exploding (not (zerop (boole 1. 8. code)))
G1checkrecursion Gcheckrecursion)
(if (zerop (boole 1. 4. code))
(<- G1prinlevel (or prinlevel 64000.)
G1prinlength (or prinlength 64000.)
G1prinendline (or prinendline 64000.)
G1prinstartline (or prinstartline 0.)
G1prinmode prinmode)
el (<- G1prinlevel 64000. G1prinlength 64000.
G1prinendline 64000. G1prinstartline 0.
G1prinmode nil)
(match inits
[← (if (numberp ←) (<- G1prinlevel ←) el (null ←)) :!←
← (if (numberp ←) (<- G1prinlength ←) el (null ←)) :!←
← (if (numberp ←) (<- G1prinendline ←) el (null ←)) :!←
← (if (numberp ←) (<- G1prinstartline ←) el (null ←)) :!←
← (or (memq ← '(grind block tblock miser crush)) (null ←)
(and (not (atom ←)) (not (atom (cdr ←))) (not (atom (cadr ←)))))
= G1prinmode :!←
! inits]))
(<- G1prinmode (if (eq G1prinmode 'grind) nil
ef (eq G1prinmode 'crush) G1crush-template
ef (eq G1prinmode 'tblock) G1tblock-template
ef (eq G1prinmode 'block) G1block-template
ef (eq G1prinmode 'miser) G1miser-template
el G1prinmode)
G1files (if (or (not (atom (car inits))) (null (car inits))) (car inits)
el inits))
;having decoded the args, do the work.
(if (and (not G1exploding) G1print-like (not (> G1prinstartline 0)))
(terpri G1files))
(if (and (atom obj) (null G1format-dispatch) (null G1format-atom) (not G1exploding))
(if G1princ-atoms (princ obj G1files) ef (not (eq obj '||)) (prin1 obj G1files))
el (G1format-init)
(if (null (errset
(if (catch (call G1format-dispatch G1prinmode obj) G1printabort)
(if (not G1exploding)
(<- G1truncated [(cursorpos G1mainfile) G1cp G1mainfile
(boole 7. code 4.) (maknum obj)
[G1prinlevel G1prinlength nil G1cline
G1prinmode G1files]])
(if (and G1printing? (plusp G1freelen))
(princ '| ---| G1files))))))
(if (null (errset (let (prin1)
(print '|error while GPRINTing:|)
(print obj))))
(let (prin1)
(print '|error while PRINTing MUNKAM of |)
(princ (maknum obj))))))
(if (and (not G1exploding) G1print-like (null G1truncated) G1printing?)
(tyo 32. G1files))
(if G1exploding
(prog2 nil (nreverse G1explode-result) (<- G1explode-result nil))
el t))))
(deffn G1format-init []
(if (null G1size)
(<- G1obj (array nil nil 100.)
G1flag (array nil fixnum 100.)
G1length (array nil fixnum 100.)
G1supstack (array nil fixnum 50.)
G1bcodestack (array nil fixnum 50.)
G1indstack (array nil fixnum 50.)
G1parents (array nil nil 50.)
G1size 100.
G1supsize 50.
G1rsize 50.))
(<- G1mainfile (if G1files (car G1files)
ef (and ↑r ↑w (car outfiles))
el tyo)
G1cp (charpos G1mainfile)
G1linelen (- (linel G1mainfile) 5)
G1maxindentlen (+ G1cp (* 4 (// (- G1linelen G1cp) 5)))
G1cline 0
G1atstart? t
G1freelen (- G1linelen G1cp)
G1pending 0
G1wentup? nil
G1printing? (not (> G1prinstartline 0))
G1tabsize 1
G1taboffset 0
G1inptr -1
G1pp 0
G1supptr 0
(G1supstack 0) 0
G1indptr 0
(G1indstack 0) G1cp
G1open-del nil
G1close-del nil
G1fcode 'never
G1bcode 0
G1level G1prinlevel
G1rindex 0
G1explode-result nil))
(deffn G1format-dispatch [template item]
(if (hunkp item)
(call G1format-hunk (if template el G11level-block-template) item)
ef (eq (typep item) 'list)
(if template (call G1format-list template item)
el (begin (head <- (car item)
symbol? <- (eq (typep head) 'symbol)
grind-fn <- (if symbol? (get head 'Ggrind-fn))
template <- (if symbol?
(if (get head 'Ggrind-template)
ef (getl head Gfn-grind-properties) G1fn-template
el G1default-symbol-car-grind-template)
ef (and (eq (typep head) 'list)
(eq (car head) 'lambda))
G1apply-template
el G1default-non-symbol-car-grind-template))
(if grind-fn (funcall grind-fn template item)
el (call G1format-list template item))))
el (if G1format-atom (funcall G1format-atom template item)
el (G1enter-obj item (if G1princ-atoms 'princ el 'prin1) nil)))
nil)
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;this does recursion checking. it looks in the array G1parents to see if the
;item has already been encountered. if so, an atom of the form ↑G is consed
;up to stand in its place. If not it is put in the array G1parents, and
;G1rindex is incremented. it is up to the format functions which call
;G1rcheck to see that the value of rindex is decremented correctly.
(deffn G1rcheck [item]
;if the item is an atom, or if we are not checking then return quick
(if (or (atom item) (not G1checkrecursion)) item
;if the array is not big enough to add this item extend the array
el (if (not (< G1rindex G1rsize))
(<- G1rsize (+ G1rindex 25.))
(*rearray G1parents (car (arraydims G1parents)) G1rsize))
;search G1parents for item if you don't find it add it at the end
(over i <- 0 by (1+ i) until nil
(if (= i G1rindex)
(<- (G1parents i) item)
(<- G1rindex (1+ G1rindex))
(return item))
;if you do find it cons up atom to return
(if (eq item (G1parents i))
(return (implode (append '(/↑) (exploden (- G1rindex i)))))))))
(deffn G1format-list [[icode ! temp] list]
(let ((orindex G1rindex) (olevel G1level)
(close-del G1close-del) (open-del G1open-del))
(<- G1open-del nil G1close-del nil)
(if (zerop G1level) (G1enter-obj '|#| 'princ nil)
ef (atom (<- list (G1rcheck list))) (G1enter-obj list 'princ nil)
el (<- G1level (1- G1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (car list))
(if G1princ-atoms (<- icode (+ icode 1 (flatc (car list))))
el (<- icode (+ icode 1 (flatsize (car list)))))))
(G1enter-obj icode nil 'start)
(G1enter-format&obj 'never 0 (or open-del '|(|) 'princ nil)
(over i <- (if (zerop G1level) 2 el G1prinlength) by (1- i) until nil
over [head ! rest] <- list by rest until nil
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(if (or (minusp i) (and (zerop i) (or rest (not (atom head)))))
(G1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(G1enter-format fcode (if (null rest) 0 el 1))
(call G1format-dispatch subtemp head)
(if (null rest) (exit))
(if (not (eq (typep (<- rest (G1rcheck rest))) 'list))
(G1enter-format&obj (caar rtemp) 1 '/. 'princ nil)
(G1enter-format 'never 0)
(call G1format-dispatch (cdar rtemp) rest)
(exit)))
(G1enter-format&obj 'never 0 (or close-del '|)|) 'princ 'end)
(<- G1rindex orindex G1level olevel))))
(defun G1format-lsubr nargs
(begin ([icode ! temp] <- (arg 1) olevel <- G1level
close-del <- G1close-del open-del <- G1open-del)
(<- G1open-del nil G1close-del nil)
(if (zerop G1level) (G1enter-obj '|#| 'princ nil)
el (<- G1level (1- G1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (arg 2))
(if G1princ-atoms (<- icode (+ icode 1 (flatc (arg 2))))
el (<- icode (+ icode 1 (flatsize (arg 2)))))))
(G1enter-obj icode nil 'start)
(G1enter-format&obj 'never 0 (or open-del '|(|) 'princ nil)
(over i <- (if (zerop G1level) 2 el G1prinlength) by (1- i) until nil
over J <- 2 by (1+ j) until (> j nargs) (arg j) -> head
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(if (or (minusp i) (and (zerop i) (or (< j nargs) (not (atom head)))))
(G1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(G1enter-format fcode (if (= j nargs) 0 el 1))
(call G1format-dispatch subtemp head))
(G1enter-format&obj 'never 0 (or close-del '|)|) 'princ 'end)
(<- G1level olevel))))
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
(deffn G1format-hunk [[icode ! temp] hunk]
(begin (orindex <- G1rindex olevel <- G1level
close-del <- G1close-del open-del <- G1open-del
end <- (1- (hunksize hunk)))
(<- G1open-del nil G1close-del nil)
(if (zerop G1level) (G1enter-obj '|#| 'princ nil)
ef (atom (<- hunk (G1rcheck hunk))) (G1enter-obj hunk 'princ nil)
el (<- G1level (1- G1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (cxr 1 hunk))
(if G1princ-atoms (<- icode (+ icode 1 (flatc (cxr 1 hunk))))
el (<- icode (+ icode 1 (flatsize (cxr 1 hunk)))))))
(G1enter-obj icode nil 'start)
(G1enter-format&obj 'never 0 (or open-del '|{|) 'princ nil)
(over i <- (if (zerop G1level) 2 el G1prinlength) by (1- i) until nil
over j <- 1 by (1+ j) until (> j end) (cxr j hunk) -> head
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(<- temp rtemp)
(if (or (minusp i) (and (zerop i) (or (< j end) (not (atom head)))))
(G1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(G1enter-format fcode 1)
(call G1format-dispatch subtemp head))
(G1enter-format (caar temp) 0)
(call G1format-dispatch (cdar temp) (cxr 0 hunk))
(G1enter-format&obj 'never 0 (or close-del '|}|) 'princ 'end)
(<- G1rindex orindex G1level olevel))))
;this section contains some special grind-fns. A grind-fn must be written when
;the template format is not powerfull enough to allow you to do what you want.
;this macro constructs grind functions which do read macro inversion of macros
;like quote (which expect that the relavent data is in the CADR), does inversion
;where the CDR is the data, and you are specifying both a new open and close delimeter.
;Gmake-inver-quote-fn2 makes inverts for macros like '`' which put the relavent data in
;the CDR. It sets up a sublist with the specified delimeters
;note that G1format-list bombs out if passed an atomic item, so this checks
;to see if the cdr of the item is atomic, and if so does not do the inversion.
;in order to improve readability, it also refuses to invert a list if it
;has only an open delimiter, and more than one element in the rest of the list.
(deffn Gmake-invert-quote-fn macro keep displace check
[← atom open-del close-del :!←]
(if close-del
`(defun (,atom Ggrind-fn) (temp item)
(cond ((cdr item)
(setq G1open-del ',open-del G1close-del ',close-del)
(cond (G1format-list (funcall G1format-list temp (cdr item)))
((G1format-list temp (cdr item)))))
((cond (G1format-list (funcall G1format-list temp (cdr item)))
((G1format-list temp item))))))
el `(defun (,atom Ggrind-fn) (temp item)
(cond ((and (cdr item) (null (cddr item)))
(setq G1open-del ',open-del G1close-del '|| G1level (1+ G1level))
(cond (G1format-list (funcall G1format-list temp (cdr item)))
((G1format-list temp (cdr item))))
(setq G1level (1- G1level)))
((cond (G1format-list (funcall G1format-list temp (cdr item)))
((G1format-list temp item))))))))
;this causes (quote ...) to print as '...
(Gmake-invert-quote-fn quote /')
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;this function works very similar to the above except it expects the goodies to be in the cdr
;and just prints them as a list if they are a list.
(deffn Gmake-invert-quote-fn2 macro keep displace check [← internal-atom external-atom]
`(defun (,internal-atom Ggrind-fn) (temp item)
(G1enter-obj 0 nil 'start)
(G1enter-format&obj 'never 0 ',external-atom 'princ nil)
(G1enter-format 'never 0)
(cond (G1format-dispatch (funcall G1format-dispatch temp (cdr item)))
((G1format-dispatch temp (cdr item))))
(G1enter-obj '|| 'princ 'end)))
;these standard definitions make the `macro print nicely.
(Gmake-invert-quote-fn2 |`-expander/|| |`|)
(Gmake-invert-quote-fn2 |`,/|| |,|)
(Gmake-invert-quote-fn2 |`,@/|| |,@|)
(Gmake-invert-quote-fn2 |`,./|| |,.|)
;this makes defun print out right by checking whether it is of the one or two
;keyword form.
(deffn defun Ggrind-fn [temp item]
(<- temp (if (and (match item [← ← ← ! ←])
(or (memq (2nd item) '(expr fexpr macro))
(memq (3rd item) '(expr fexpr macro))))
G1defun2-template
el G1defun1-template))
(call G1format-list temp item))
;this makes the Gprinter obay the grind-macroexpanded flag from the
;file DEFMAX so that macro expansions created with
;macro-expansion-use=macroexpanded print pretty.
(defun (macroexpanded Ggrind-fn) (temp item)
(setq item (cond (grind-macroexpanded (cadddr (cdr item)))
(t (cadddr item))))
(setq G1level (1+ G1level))
(cond (G1format-dispatch (funcall G1format-dispatch temp item))
((G1format-dispatch temp item)))
(setq G1level (1- G1level)))
;this takes care of making the tags come out right in a prog or do. it looks
;complex but really it is exactly the same as G1format-list with a piece added in
;the middle that works with the tags. it works even if there are two or more
;tags in a row.
(deffn prog Ggrind-fn [unused-template list]
;if list is short and has no tags then print it like a list.
;otherwise we force things to be on separate lines even if there are no tags.
(if (over (cddr list) until (atom ←)
over i <- 0 by (1+ i) until nil
fastand (if (> i 10) (return nil))
(not (atom ←)))
(call G1format-list G1fn-template list)
el (begin (orindex <- G1rindex olevel <- G1level
default-bcode bcode
any-labs-yet? <- nil)
(if G1princ-atoms (<- default-bcode (1+ (flatc (car list))))
el (<- default-bcode (1+ (flatsize (car list)))))
(<- bcode default-bcode)
(if (zerop G1level) (G1enter-obj '|#| 'princ nil)
ef (atom (<- list (G1rcheck list))) (G1enter-obj list 'princ nil)
el (<- G1level (1- G1level))
(G1enter-obj 1 nil 'start)
(G1enter-format&obj 'never 0 '|(| 'princ nil)
(over i <- (if (zerop G1level) 2 el G1prinlength) by (1- i) until nil
over [head ! rest] <- list by rest until nil
over k <- 1 by (1- k) until nil
(if (or (minusp i) (and (zerop i) (or rest (not (atom head)))))
(G1enter-format&obj 'never 0 '|...| 'princ nil)
(exit))
;this is the new part which figures the undenting of the tags.
(if (minusp k)
(if (and (atom head) head)
(if G1princ-atoms
(<- bcode (- bcode 1 (flatc head)))
el (<- bcode (- bcode 1 (flatsize head))))
(G1enter-format&obj
(if any-labs-yet? 'never el 'always) 1
head (if G1princ-atoms 'princ el 'prin1) nil)
(<- any-labs-yet? t)
el (if (not any-labs-yet?)
(G1enter-format&obj 'always default-bcode '|| nil nil)
el (G1enter-format&obj 'never (max 0 bcode) '|| nil nil)
(<- bcode default-bcode any-labs-yet? nil))
(G1enter-format 'never (if (null rest) 0 el 1))
(call G1format-dispatch nil head))
el (G1enter-format 'never (if (null rest) 0 el 1))
(call G1format-dispatch G11level-block-template head))
;back to normal stuff from G1format-list
(if (null rest) (exit))
(if (not (eq (typep (<- rest (G1rcheck rest))) 'list))
(G1enter-format&obj 'never 1 '/. 'princ nil)
(G1enter-format 'never 0)
(call G1format-dispatch nil rest)
(exit)))
(G1enter-format&obj 'never 0 '|)| 'princ 'end)
(<- G1rindex orindex G1level olevel)))))
;do can be handled just like prog.
(putprop 'do (get 'prog 'Ggrind-fn) 'Ggrind-fn)
;G1enter makes things easier for the format functions by maintaining the
;consistency of the intermediate structure. In particular as sublists grow,
;it keeps the length, inner-always and complete fields accurate. in order to
;do this, it needs to know where the the superiors of the current element are.
;this is the function of G1supstack. it contains the offsets to the superiors.
;if the end of the arrays are reached, then it shifts things over. (this looks
;slow compared with using a queue rapping around in the arrays, but it saves
;enough overhead in other places that it wins in the long run. G1supstack
;contains offsets so that nothing special has to be done when things are
;shifted over.) (note that the arrays are expanded if they need to be.)
;special checks are made so the G1enter never bothers to update an elemetn
;which G1printout has already passed over. (this also avoids referenceing
;outside the arrays.) the zero position of G1supstack is left unused in order
;to solve a lot of fencepost problems. it gets written in now and then though
;it logically shouldn't.
(deffn G1enter-obj [obj pcode lcode]
(begin (flag <- (flags (if (eq pcode 'prin1) (flags 'prin1)
ef (eq pcode 'princ) (flags 'princ)
el 0)
(if (eq G1fcode 'never) (flags 'never)
ef (eq G1fcode 'normal) (flags 'normal)
ef (eq G1fcode 'tblock) (flags 'tblock)
ef (eq G1fcode 'block) (flags 'block)
el;(eq G1fcode 'always)
(flags 'always))
(if (eq lcode 'start) (flags 'list-start)
ef (eq lcode 'end)
(flags 'list-end 'complete (G1bcodestack G1supptr))
el;(eq lcode nil)
(flags 'complete G1bcode)))
length <- (if (list-start? flag) 0
ef (prin1? flag) (+ (bcode flag) (flatsize obj))
ef (princ? flag) (+ (bcode flag) (flatc obj))
el (bcode flag)))
(if G1exploding
(if (princ? flag)
(<- G1explode-result (nreconc (explodec obj) G1explode-result))
ef (prin1? flag)
(<- G1explode-result (nreconc (explode obj) G1explode-result)))
(over i <- (bcode flag) by (1- i) until (not (plusp i))
(pushonto G1explode-result '| |))
(if (list-start? flag)
(<- G1supptr (1+ G1supptr)
(G1bcodestack G1supptr) G1bcode)
ef (list-end? flag)
(<- G1supptr (1- G1supptr)))
;otherwise go to next queue element and queue the stuff up.
el (<- G1inptr (1+ G1inptr)
(G1supstack G1supptr) (1+ (G1supstack G1supptr)))
;check if we have gone passed the end of the queue, if we have shift things over, or
;(if we must) extend the size of the arrays.
(if (not (< G1inptr G1size))
(if (< G1pp 10.)
(<- G1size (+ G1size 10.))
(*rearray G1obj (car (arraydims G1obj)) G1size)
(*rearray G1flag (car (arraydims G1flag)) G1size)
(*rearray G1length (car (arraydims G1length)) G1size)
el (over j <- G1pp by (1+ j) until (= j G1size)
over i <- 0 by (1+ i) until nil
(<- (G1obj i) (G1obj j)
(G1flag i) (G1flag j)
(G1length i) (G1length j)))
(<- G1inptr (- G1inptr G1pp)
G1pp 0)))
;fill in the slots in the new queue element.
(<- (G1obj G1inptr) obj
(G1flag G1inptr) flag
(G1length G1inptr) length)
;update the lengths of the superiors of the new queue element.
(over i <- G1supptr by (1- i) until (zerop i)
over j <- (- G1inptr (G1supstack i)) by (- j (G1supstack i)) until (< j G1pp)
(<- (G1length j) (+ length (G1length j))))
;if this queue element has the always? bit on, put the inner-always bit on in its superiors
(if (always? flag)
(over i <- G1supptr by (1- i) until (zerop i)
over j <- (- G1inptr (G1supstack i)) by (- j (G1supstack i)) until (< j G1pp)
(<- (G1flag j) (flags (G1flag j) 'inner-always))))
;if this queue element is the start of a list push it onto the supstack. (extend if needed)
(if (list-start? flag)
(<- G1supptr (1+ G1supptr))
(if (not (< G1supptr G1supsize))
(<- G1supsize (+ G1supsize 10.))
(*rearray G1supstack (car (arraydims G1supstack)) G1supsize)
(*rearray G1indstack (car (arraydims G1indstack)) G1supsize)
(*rearray G1bcodestack (car (arraydims G1bcodestack)) G1supsize))
(<- (G1supstack G1supptr) 0
(G1bcodestack G1supptr) G1bcode)
;if this element is the end of a list mark the superior complete and pop it off the supstack.
ef (list-end? flag)
(let ((i (- G1inptr (G1supstack G1supptr))))
(if (not (> G1pp i))
(<- (G1flag i) (flags (G1flag i) 'complete))))
(<- G1supptr (1- G1supptr)
(G1supstack G1supptr) (+ (G1supstack G1supptr) (G1supstack (1+ G1supptr)))))
;call G1printout to see if anything can get printed out.
(G1printout)))
nil)
;this is the function that actually decides how things get printed out. it is
;essentially an interpreter for the intermediate structure looked at as a
;program. it implements all of the meanings of the codes. (comments near the
;beginning discuss the semantics of the various flags.) G1enter puts enough
;information at each node, that G1printout can make almost all of its
;decisions based solely on the information at one node and general information
;about where it is in printing. (tblocking is the only major exception, in
;that case it looks at a bunch of nodes in order to figure out what the tab
;size should be.)
(deffn G1printout []
;if there is no more intermediate structure exit
(loop (flag)
(if (> G1pp G1inptr) (exit))
(<- flag (G1flag G1pp))
;if it the next thing is ready to print, and we may have to tab before it, and
;we don't yet know the tabsize, find it out.
(if (and (tblock? flag) (complete? flag) (= G1tabsize 1))
(begin (n <- (max 2 (G1length G1pp))
i <- 0
max <- (over j <- G1pp by (1+ j) until (> j G1inptr)
(G1flag j) -> flag
return n
(if (= i 0) (<- n (max n (G1length j))))
(if (list-start? flag) (<- i (1+ i))
ef (list-end? flag) (<- i (1- i))))
space <- (- G1linelen (G1indstack G1indptr)))
(<- max (min space (+ max (// max 5)))
G1tabsize (// space (// space max))
G1taboffset (- (\ space G1tabsize) G1tabsize))))
;if we are not already at the start of a line see if we have to put a crlf
;before the next thing.
(if (not G1atstart?)
;if we have to tab before the next thing, then make sure we are in the right column
(if (and (tblock? flag) (complete? flag))
(let ((j (\ (- G1freelen G1taboffset) G1tabsize)))
(<- G1pending (+ G1pending j)
G1freelen (- G1freelen j))))
;check if the code implies doing a terpri
(if (or (always? flag) ;must always crlf
(normal? flag) ;must if we are inside
(and (or (block? flag) (tblock? flag)) ;blocking
(or G1wentup? ;prior thing had CRLF
(inner-always? flag) ;this has CRLF in it
(and (> (G1length G1pp) G1freelen) ;this won't fit
(< (G1indstack G1indptr) ;we will have more
(- G1linelen G1freelen))))) ;room if we CRLF
(and (never? flag) ;never CRLF
(not (list-start? flag)) ;but not sublist
(> (G1length G1pp) (+ 4 G1freelen)) ;obj really won't fit
(< (G1indstack G1indptr) ;we will have more
(- G1linelen G1freelen)))) ;room if we CRLF
;we do need a new line set it up
(<- G1atstart? t
G1wentup? nil
G1cline (1+ G1cline)
G1pending (G1indstack G1indptr)
G1freelen (- G1linelen G1pending))
;check if we have exceeded prinendline if so stop printing
(if (> G1cline G1prinendline)
(throw '|G1prinendline exceeded| G1printabort))
;do the terpri and set up for the correct indentation
(if G1printing? (terpri G1files)
ef (<- G1printing? (not (> G1prinstartline G1cline)))
(<- G1pending (- G1pending G1cp)))))
;if the current thing won't go on one line (because it is too long or has an
;inner-always) then go down into it calculating new indentation level
(if (and (list-start? flag) (or (inner-always? flag) (> (G1length G1pp) G1freelen)))
(<- G1indptr (1+ G1indptr)
(G1indstack G1indptr)
(let ((i (G1obj G1pp))) ;additional indentation
(if (> i G1maxindentlen) ;if very large
(<- i 3)) ;make be small
(<- i (+ i (- G1linelen G1freelen))) ;get new indentation
(<- i (max G1cp i)) ;don't go left of G1cp
(if (> i G1maxindentlen) ;if too far use
(<- i (+ G1cp (// (- G1linelen G1cp) 5) ;20% indetation
(\ i G1maxindentlen)))) ;plus proper remainder
i)
G1pp (1+ G1pp)
G1tabsize 1)
;otherwise if this item is completed then it will fit on one line and we go
;ahead and print it out. (we count delemiters to know when we are done)
ef (complete? flag)
(<- G1freelen (- G1freelen (G1length G1pp))
G1atstart? nil)
(loop (i <- 0)
(if (list-start? flag) (<- i (1+ i))
el (if (list-end? flag) (<- i (1- i)))
(if G1printing?
(over j <- G1pending by (1- j) until (not (plusp j))
(tyo 32. G1files))
(if (princ? flag) (princ (G1obj G1pp) G1files)
ef (prin1? flag) (prin1 (G1obj G1pp) G1files)))
(<- G1pending (bcode flag)))
(<- G1pp (1+ G1pp))
(if (zerop i) (exit)
;if we have just gone over a list end, then pop up a level
ef (minusp i)
(<- G1indptr (1- G1indptr)
G1wentup? t
G1tabsize 64000.)
(exit))
(<- flag (G1flag G1pp)))
;if the current thing wasn't complete either, then we quit because we don't
;have enough information to decide what to do.
el (exit))))
;this is a macro expanded version if this file. the fasl version has actually been produced
;by compiling this version. it is included because it may be more readable to some, and
;in the hope that it will allow Gprint to be maintained after my macros and I have gone.
;all of the comments above apply to the expanded version.
(declare '(macro expanded version of code |two )) at end to match|
(DECLARE (FIXNUM I J K N LENGTH END RINDEX MAX DEFAULT-BCODE BCODE SPACE LEVEL FLAGS)
(SPECIAL GCHECKRECURSION PRINLEVEL PRINLENGTH PRINMODE
PRINENDLINE PRINSTARTLINE ↑R ↑W OUTFILES
GRINDEF GRINDPROPERTIES GFN-GRIND-PROPERTIES G1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE
G1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE TYO G1FORMAT-DISPATCH G1FORMAT-LIST
G1FORMAT-ATOM G1FORMAT-HUNK GRIND-MACROEXPANDED)
(SPECIAL G1PRINLEVEL G1PRINLENGTH G1PRINENDLINE G1PRINSTARTLINE
G1CP G1LINELEN G1MAXINDENTLEN G1CLINE G1FREELEN
G1PENDING G1TABSIZE G1TABOFFSET G1INPTR G1PP
G1SUPPTR G1INDPTR G1SIZE G1SUPSIZE G1RSIZE
G1PRINMODE G1CHECKRECURSION G1MAINFILE G1TRUNCATED G1FILES
G1ATSTART? G1WENTUP? G1PRINTING? G1OBJ G1FLAG
G1LENGTH G1SUPSTACK G1INDSTACK G1PARENTS G1NOWPRINTING
G1FCODE G1BCODE G1BCODESTACK G1LEVEL G1RINDEX
G1OPEN-DEL G1CLOSE-DEL G1PRINC-ATOMS G1PRINT-LIKE G1EXPLODING
G1EXPLODE-RESULT)
(SPECIAL G1MISER-TEMPLATE G1BLOCK-TEMPLATE
G1CRUSH-TEMPLATE G1FN-TEMPLATE G11LEVEL-BLOCK-TEMPLATE
G1DEFUN1-TEMPLATE G1DEFUN2-TEMPLATE G11LEVEL-TBLOCK-TEMPLATE
G1APPLY-TEMPLATE G11LEVEL-MISER-TEMPLATE G1TBLOCK-TEMPLATE)
(*LEXPR GPRIN1 GPRINT PRINL PRINL1))
(DEFUN GMAKE-TEMPLATE (PATTERN) (GMAKE-TEMPLATE1 PATTERN NIL NIL))
(DEFUN GMAKE-TEMPLATE1 (PATTERN OLDBACKLIST NEWBACKLIST)
(COND ((ATOM PATTERN) PATTERN)
((MEMQ PATTERN OLDBACKLIST)
((LAMBDA (OVERVAROLD OLD OVERVARNEW NEW)
(PROGN (SETQ OVERVAROLD OLDBACKLIST) (SETQ OVERVARNEW NEWBACKLIST))
(PROG NIL
U1←L (PROGN (SETQ OLD (CAR OVERVAROLD)) (SETQ NEW (CAR OVERVARNEW)))
(COND ((EQ OLD PATTERN) (RETURN NEW)))
(PROGN (SETQ OVERVAROLD (CDR OVERVAROLD)) (SETQ OVERVARNEW (CDR OVERVARNEW)))
(GO U1←L)))
NIL NIL NIL NIL))
((EQ (CAR PATTERN) '↑)
((LAMBDA (OVERVARNEW NEW ICOUNT)
(PROGN (SETQ OVERVARNEW NEWBACKLIST) (SETQ ICOUNT (1- (CDR PATTERN))))
(PROG NIL
U1←L (SETQ NEW (CAR OVERVARNEW))
(COND ((ZEROP ICOUNT) (RETURN NEW)))
(PROGN (SETQ OVERVARNEW (CDR OVERVARNEW)) (SETQ ICOUNT (1- ICOUNT)))
(GO U1←L)))
NIL NIL NIL))
(((LAMBDA (NEWCONS)
(SETQ OLDBACKLIST (CONS PATTERN OLDBACKLIST))
(SETQ NEWBACKLIST (CONS NEWCONS NEWBACKLIST))
(RPLACA NEWCONS (GMAKE-TEMPLATE1 (CAR PATTERN) OLDBACKLIST NEWBACKLIST))
(RPLACD NEWCONS (GMAKE-TEMPLATE1 (CDR PATTERN) OLDBACKLIST NEWBACKLIST))
NEWCONS)
(NCONS NIL)))))
(DEFUN G1SET-UP-TEMPLATES NIL
(PROGN (SETQ G1MISER-TEMPLATE (GMAKE-TEMPLATE '(1. (NEVER ↑ . 3.) (NORMAL ↑ . 4.) ↑ . 1.)))
(SETQ G1CRUSH-TEMPLATE (GMAKE-TEMPLATE '(-900. (NEVER ↑ . 3.) ↑ . 1.)))
(SETQ G1BLOCK-TEMPLATE (GMAKE-TEMPLATE '(1. (NEVER ↑ . 3.) (BLOCK ↑ . 4.) ↑ . 1.)))
(SETQ G1TBLOCK-TEMPLATE (GMAKE-TEMPLATE '(1. (NEVER ↑ . 3.) (TBLOCK ↑ . 4.) ↑ . 1.)))
(SETQ G1FN-TEMPLATE (GMAKE-TEMPLATE '(NIL (NEVER) (NEVER) (NORMAL) ↑ . 1.)))
(SETQ G11LEVEL-MISER-TEMPLATE (GMAKE-TEMPLATE '(1. (NEVER) (NORMAL) ↑ . 1.)))
(SETQ G11LEVEL-BLOCK-TEMPLATE (GMAKE-TEMPLATE '(1. (BLOCK) ↑ . 1.)))
(SETQ G11LEVEL-TBLOCK-TEMPLATE (GMAKE-TEMPLATE '(1. (TBLOCK) ↑ . 1.)))
(SETQ G1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE G1FN-TEMPLATE)
(SETQ G1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE G11LEVEL-MISER-TEMPLATE)
(PUTPROP 'LAMBDA
(GMAKE-TEMPLATE '(2. (NEVER) (NEVER 1. (BLOCK) ↑ . 1.) (NORMAL) ↑ . 1.))
'GGRIND-TEMPLATE)
(SETQ G1APPLY-TEMPLATE (GMAKE-TEMPLATE '(1. (NEVER) (BLOCK) ↑ . 1.)))
(PUTPROP 'SETQ (GMAKE-TEMPLATE '(NIL (NEVER) (NEVER) (BLOCK) (ALWAYS) (BLOCK) ↑ . 2.)) 'GGRIND-TEMPLATE)
(PUTPROP 'COND
(GMAKE-TEMPLATE '(NIL
(NEVER)
(NEVER 1. (NEVER) (NORMAL) ↑ . 1.)
(ALWAYS 1. (NEVER) (NORMAL) ↑ . 1.)
↑
. 1.))
'GGRIND-TEMPLATE)
(SETQ G1DEFUN1-TEMPLATE
(GMAKE-TEMPLATE '(2. (NEVER) (NEVER 1. (NEVER) (NORMAL) ↑ . 1.) (NEVER) (NORMAL) ↑ . 1.)))
(SETQ G1DEFUN2-TEMPLATE (GMAKE-TEMPLATE '(2. (NEVER) (NEVER) (NEVER) (NEVER) (NORMAL) ↑ . 1.)))))
(G1SET-UP-TEMPLATES)
(DEFUN G1SET-UP-GLOBALS NIL
(SETQ G1TRUNCATED NIL)
((LAMBDA (|OVERVAR([ ATOM VAL)| VAL ATOM)
(SETQ |OVERVAR([ ATOM VAL)|
'((PRINLEVEL NIL)
(PRINLENGTH NIL)
(PRINMODE GRIND)
(PRINSTARTLINE NIL)
(PRINENDLINE NIL)
(GCHECKRECURSION NIL)
(GFN-GRIND-PROPERTIES (EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY AUTOLOAD))
(GRINDPROPERTIES (EXPR FEXPR MACRO))
(GRINDEF NIL)
(G1FORMAT-DISPATCH NIL)
(G1FORMAT-LIST NIL)
(G1FORMAT-HUNK NIL)
(G1FORMAT-ATOM NIL)
(G1NOWPRINTING NIL)
(G1SIZE NIL)))
(PROG NIL
U1←L (COND ((NULL |OVERVAR([ ATOM VAL)|) (RETURN NIL)))
((LAMBDA (U1←ITEM) (SETQ ATOM (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) (SETQ VAL (CAR U1←ITEM)))
(CAR |OVERVAR([ ATOM VAL)|))
(COND ((NOT (BOUNDP ATOM)) (SET ATOM VAL)))
(SETQ |OVERVAR([ ATOM VAL)| (CDR |OVERVAR([ ATOM VAL)|))
(GO U1←L)))
NIL NIL NIL))
(G1SET-UP-GLOBALS)
(DEFUN G1SET-UP-PRINTER NIL
(SSTATUS TTYINT 19. 'GPRINTABORT)
(SSTATUS TTYINT 3. 'GCONTINUE)
(ENDPAGEFN TYO 'G1ENDPAGEFN)
(SETQ PRIN1 'GPRIN1))
(DEFUN G1REM-PRINTER NIL
(COND ((EQ (STATUS TTYINT 19.) 'GPRINTABORT) (SSTATUS TTYINT 19. NIL)))
(COND ((EQ (STATUS TTYINT 3.) 'GCONTINUE) (SSTATUS TTYINT 3. NIL)))
(COND ((EQ (ENDPAGEFN TYO) 'G1ENDPAGEFN) (ENDPAGEFN TYO '+INTERNAL-TTY-ENDPAGEFN)))
(SETQ PRIN1 NIL)
((LAMBDA (OVERVAR← ←)
(SETQ OVERVAR←
'((MACRO G1ENTER-FORMAT)
(MACRO G1ENTER-FORMAT&OBJ)
(SUBR GMAKE-TEMPLATE)
(SUBR GMAKE-TEMPLATE1)
(SUBR G1SET-UP-TEMPLATES)
(SUBR G1SET-UP-GLOBALS)
(SUBR G1SET-UP-PRINTER)
(SUBR G1REM-PRINTER)
(LSUBR GPRIN1)
(LSUBR GPRINC)
(LSUBR GPRINT)
(LSUBR GPRINL1)
(LSUBR GPRINLC)
(LSUBR GPRINL)
(SUBR GEXPLODE)
(SUBR GEXPLODEC)
(LSUBR GEXPLODEL)
(FSUBR GRINDEF)
(SUBR G1PRINTABORT)
(SUBR GCONTINUE)
(SUBR G1ENDPAGE-FN)
(SUBR G1PRINTER)
(SUBR G1FORMAT-INIT)
(SUBR G1FORMAT-DISPATCH)
(SUBR G1RCHECK)
(SUBR G1FORMAT-LIST)
(LSUBR G1FORMAT-LSUBR)
(SUBR G1FORMAT-HUNK)
(MACRO GMAKE-INVERT-QUOTE-FN)
(MACRO GMAKE-INVERT-QUOTE-FN2)
(GGRIND-FN QUOTE)
(GGRIND-FN DEFUN)
(GGRIND-FN PROG)
(GGRIND-FN DO)
(GGRIND-FN MACROEXPANDED)
(SUBR G1SET-UP-MACROS)
(SUBR G1ENTER-OBJ)
(SUBR G1PRINTOUT)))
(PROG NIL
U1←L (COND ((NULL OVERVAR←) (RETURN NIL)))
(SETQ ← (CAR OVERVAR←))
(REMPROP (CDR ←) (CAR ←))
(SETQ OVERVAR← (CDR OVERVAR←))
(GO U1←L)))
NIL NIL)
((LAMBDA (OVERVAR← ←)
(SETQ OVERVAR← '(G1OBJ G1FLAG G1LENGTH G1SUPSTACK G1BCODESTACK G1INDSTACK G1PARENTS G1POBJ))
(PROG NIL
U1←L (COND ((NULL OVERVAR←) (RETURN NIL)))
(SETQ ← (CAR OVERVAR←))
(MAKUNBOUND ←)
(SETQ OVERVAR← (CDR OVERVAR←))
(GO U1←L)))
NIL NIL))
(DEFUN GPRIN1 NARGS (G1PRINTER 0. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN GPRINC NARGS (G1PRINTER 1. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN GPRINT NARGS (G1PRINTER 2. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINL1 NARGS (G1PRINTER 4. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINLC NARGS (G1PRINTER 5. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINL NARGS (G1PRINTER 6. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN GEXPLODE (OBJ) (G1PRINTER 8. OBJ NIL))
(DEFUN GEXPLODEC (OBJ) (G1PRINTER 9. OBJ NIL))
(DEFUN GEXPLODEL NARGS (G1PRINTER 14. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN GRINDEF FEXPR (ARG)
((LAMBDA (ATOMS PROPS SELECTEDPROPS)
(PROGN ((LAMBDA (U1←ITEM)
(OR (AND (NOT (ATOM U1←ITEM))
(NOT (ATOM (CAR U1←ITEM)))
(PROGN (SETQ PROPS (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(SETQ ATOMS U1←ITEM))
(COND (ARG (SETQ GRINDEF ARG))
(GRINDEF)))
(SETQ SELECTEDPROPS (APPEND PROPS GRINDPROPERTIES)))
((LAMBDA (OVERVARATOM ATOM TRACED)
(SETQ OVERVARATOM ATOMS)
(PROG NIL
U1←L (COND ((NULL OVERVARATOM) (RETURN NIL)))
(PROGN (SETQ ATOM (CAR OVERVARATOM)) (SETQ TRACED (AND (STATUS FEATURE TRACE) (MEMQ ATOM (TRACE)))))
((LAMBDA (REST PROP IND)
((LAMBDA (U1←ITEM)
(SETQ IND (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ PROP (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
(PLIST ATOM))
(PROG NIL
U1←L (COND ((NULL IND) (RETURN NIL)))
(COND ((AND (COND ((AND TRACED (MEMQ IND '(EXPR FEXPR MACRO)))
(SETQ TRACED NIL)
(COND ((MEMQ IND SELECTEDPROPS) (TERPRI) (PRINC '|;traced|)))
NIL)
(T))
(MEMQ IND SELECTEDPROPS))
(COND ((AND (NOT (ATOM PROP)) (EQ (CAR PROP) 'LAMBDA))
(PRINL (CONS 'DEFUN
(NCONC (COND ((EQ IND 'EXPR) (LIST ATOM))
((MEMQ IND '(FEXPR MACRO)) (LIST ATOM IND))
((LIST (LIST ATOM IND))))
(CDR PROP)))
'GRIND))
((PRINL (LIST 'DEFPROP ATOM PROP IND) 'GRIND)))))
((LAMBDA (U1←ITEM)
(SETQ IND (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ PROP (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
REST)
(GO U1←L)))
NIL NIL NIL)
(SETQ OVERVARATOM (CDR OVERVARATOM))
(GO U1←L)))
NIL NIL NIL))
NIL NIL NIL)
'||)
(DEFUN GPRINTABORT (UNUSED-F UNUSED-CH)
(NOINTERRUPT NIL)
(TYI TYI)
(COND (G1NOWPRINTING (ERRSET (THROW '|aborted| G1PRINTABORT)))))
(DECLARE ((LAMBDA (OBARRAY) (REMPROP (INTERN 'CURSORPOS) (INTERN 'ACS))) SOBARRAY))
(DEFUN GCONTINUE (UNUSED-F UNUSED-CH)
(NOINTERRUPT NIL)
(TYI TYI)
(COND (G1TRUNCATED
((LAMBDA (C1PARAMS C1FILES C1OBJ C1CODE C1MAINFILE C1CP C1TRUNCATEPOS ON-SAME-LINE)
(PROGN ((LAMBDA (U1←ITEM)
(SETQ C1TRUNCATEPOS (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ C1CP (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ C1MAINFILE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ C1CODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ C1OBJ (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
((LAMBDA (U1←ITEM)
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ C1FILES (CAR U1←ITEM)))
(CAR U1←ITEM))
(SETQ C1PARAMS (CAR U1←ITEM)))
G1TRUNCATED)
(SETQ ON-SAME-LINE (= (CAR C1TRUNCATEPOS) (CAR (CURSORPOS C1MAINFILE)))))
(CURSORPOS (CAR C1TRUNCATEPOS) (CDR C1TRUNCATEPOS) C1MAINFILE)
(CURSORPOS 'L C1MAINFILE)
(COND (ON-SAME-LINE (TERPRI C1FILES))
((TERPRI C1MAINFILE)))
((LAMBDA (I)
(SETQ I C1CP)
(PROG NIL
U1←L (COND ((ZEROP I) (RETURN NIL)))
(TYO 32. C1MAINFILE)
(SETQ I (1- I))
(GO U1←L)))
0.)
(G1PRINTER C1CODE ((LAMBDA (FOO) (MUNKAM (+ FOO 0.))) C1OBJ) C1PARAMS)
(COND ((NOT ON-SAME-LINE) (TERPRI G1FILES))))
NIL NIL NIL NIL NIL NIL NIL NIL)))
'||)
(DEFUN G1ENDPAGEFN (TTY)
(NOINTERRUPT NIL)
(CURSORPOS 'Z TTY)
(CURSORPOS 'L TTY)
(PRINC '|**more**| TTY)
((LAMBDA (ECHOFILES) (TYI)) NIL)
(CURSORPOS 'Z TTY)
(CURSORPOS 'L TTY)
(CURSORPOS 'TOP TTY)
(CURSORPOS 'L TTY))
(DEFUN G1PRINTER (CODE OBJ INITS)
(COND (G1NOWPRINTING
((LAMBDA (G1NOWPRINTING G1OBJ G1FLAG G1LENGTH G1SUPSTACK G1INDSTACK G1PARENTS G1SIZE G1SUPSIZE G1RSIZE
G1PRINLEVEL G1PRINLENGTH G1PRINENDLINE G1PRINSTARTLINE G1CP G1LINELEN G1MAXINDENTLEN G1CLINE
G1FREELEN G1PENDING G1TABSIZE G1TABOFFSET G1INPTR G1PP G1SUPPTR G1INDPTR G1PRINMODE
G1CHECKRECURSION G1MAINFILE G1FILES G1ATSTART? G1WENTUP? G1PRINTING? G1FCODE G1BCODE
G1BCODESTACK G1OPEN-DEL G1CLOSE-DEL G1LEVEL G1RINDEX G1PRINC-ATOMS G1PRINT-LIKE G1EXPLODING
G1EXPLODE-RESULT)
(G1PRINTER CODE OBJ INITS))
NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
(((LAMBDA (G1NOWPRINTING)
(SETQ G1NOWPRINTING T)
(PROGN (SETQ G1PRINC-ATOMS (NOT (ZEROP (BOOLE 1. 1. CODE))))
(SETQ G1PRINT-LIKE (NOT (ZEROP (BOOLE 1. 2. CODE))))
(SETQ G1EXPLODING (NOT (ZEROP (BOOLE 1. 8. CODE))))
(SETQ G1CHECKRECURSION GCHECKRECURSION))
(COND ((ZEROP (BOOLE 1. 4. CODE))
(PROGN (SETQ G1PRINLEVEL (OR PRINLEVEL 64000.))
(SETQ G1PRINLENGTH (OR PRINLENGTH 64000.))
(SETQ G1PRINENDLINE (OR PRINENDLINE 64000.))
(SETQ G1PRINSTARTLINE (OR PRINSTARTLINE 0.))
(SETQ G1PRINMODE PRINMODE)))
(T
(PROGN (SETQ G1PRINLEVEL 64000.)
(SETQ G1PRINLENGTH 64000.)
(SETQ G1PRINENDLINE 64000.)
(SETQ G1PRINSTARTLINE 0.)
(SETQ G1PRINMODE NIL))
((LAMBDA (U1←ITEM)
(AND (OR (AND (NOT (ATOM U1←ITEM))
(COND ((NUMBERP (CAR U1←ITEM)) (SETQ G1PRINLEVEL (CAR U1←ITEM)))
((NULL (CAR U1←ITEM))))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(OR (AND (NOT (ATOM U1←ITEM))
(COND ((NUMBERP (CAR U1←ITEM)) (SETQ G1PRINLENGTH (CAR U1←ITEM)))
((NULL (CAR U1←ITEM))))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(OR (AND (NOT (ATOM U1←ITEM))
(COND ((NUMBERP (CAR U1←ITEM)) (SETQ G1PRINENDLINE (CAR U1←ITEM)))
((NULL (CAR U1←ITEM))))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(OR (AND (NOT (ATOM U1←ITEM))
(COND ((NUMBERP (CAR U1←ITEM)) (SETQ G1PRINSTARTLINE (CAR U1←ITEM)))
((NULL (CAR U1←ITEM))))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(OR (AND (NOT (ATOM U1←ITEM))
(OR (MEMQ (CAR U1←ITEM) '(GRIND BLOCK TBLOCK MISER CRUSH))
(NULL (CAR U1←ITEM))
(AND (NOT (ATOM (CAR U1←ITEM)))
(NOT (ATOM (CDR (CAR U1←ITEM))))
(NOT (ATOM (CADR (CAR U1←ITEM))))))
(PROGN (SETQ G1PRINMODE (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) T))
T)
(PROGN (SETQ INITS U1←ITEM) T)))
INITS)))
(PROGN (SETQ G1PRINMODE
(COND ((EQ G1PRINMODE 'GRIND) NIL)
((EQ G1PRINMODE 'CRUSH) G1CRUSH-TEMPLATE)
((EQ G1PRINMODE 'TBLOCK) G1TBLOCK-TEMPLATE)
((EQ G1PRINMODE 'BLOCK) G1BLOCK-TEMPLATE)
((EQ G1PRINMODE 'MISER) G1MISER-TEMPLATE)
(G1PRINMODE)))
(SETQ G1FILES
(COND ((OR (NOT (ATOM (CAR INITS))) (NULL (CAR INITS))) (CAR INITS))
(INITS))))
(COND ((AND (NOT G1EXPLODING) G1PRINT-LIKE (NOT (> G1PRINSTARTLINE 0.))) (TERPRI G1FILES)))
(COND ((AND (ATOM OBJ) (NULL G1FORMAT-DISPATCH) (NULL G1FORMAT-ATOM) (NOT G1EXPLODING))
(COND (G1PRINC-ATOMS (PRINC OBJ G1FILES))
((NOT (EQ OBJ '||)) (PRIN1 OBJ G1FILES))))
(T
(G1FORMAT-INIT)
(COND ((NULL (ERRSET (COND ((CATCH (COND (G1FORMAT-DISPATCH
(FUNCALL G1FORMAT-DISPATCH G1PRINMODE OBJ))
((G1FORMAT-DISPATCH G1PRINMODE OBJ)))
G1PRINTABORT)
(COND ((NOT G1EXPLODING)
(SETQ G1TRUNCATED
(LIST (CURSORPOS G1MAINFILE)
G1CP
G1MAINFILE
(BOOLE 7. CODE 4.)
(MAKNUM OBJ)
(LIST G1PRINLEVEL
G1PRINLENGTH
NIL
G1CLINE
G1PRINMODE
G1FILES)))
(COND ((AND G1PRINTING? (PLUSP G1FREELEN))
(PRINC '| ---| G1FILES)))))))))
(COND ((NULL (ERRSET ((LAMBDA (PRIN1) (PRINT '|error while GPRINTing:|) (PRINT OBJ)) NIL)))
((LAMBDA (PRIN1) (PRINT '|error while PRINTing MUNKAM of |) (PRINC (MAKNUM OBJ)))
NIL)))))))
(COND ((AND (NOT G1EXPLODING) G1PRINT-LIKE (NULL G1TRUNCATED) G1PRINTING?) (TYO 32. G1FILES)))
(COND (G1EXPLODING (PROG2 NIL (NREVERSE G1EXPLODE-RESULT) (SETQ G1EXPLODE-RESULT NIL)))
(T)))
NIL))))
(DEFUN G1FORMAT-INIT NIL
(COND ((NULL G1SIZE)
(PROGN (SETQ G1OBJ (ARRAY NIL NIL 100.))
(SETQ G1FLAG (ARRAY NIL FIXNUM 100.))
(SETQ G1LENGTH (ARRAY NIL FIXNUM 100.))
(SETQ G1SUPSTACK (ARRAY NIL FIXNUM 50.))
(SETQ G1BCODESTACK (ARRAY NIL FIXNUM 50.))
(SETQ G1INDSTACK (ARRAY NIL FIXNUM 50.))
(SETQ G1PARENTS (ARRAY NIL NIL 50.))
(SETQ G1SIZE 100.)
(SETQ G1SUPSIZE 50.)
(SETQ G1RSIZE 50.))))
(PROGN (SETQ G1MAINFILE
(COND (G1FILES (CAR G1FILES))
((AND ↑R ↑W (CAR OUTFILES)))
(TYO)))
(SETQ G1CP (CHARPOS G1MAINFILE))
(SETQ G1LINELEN (- (LINEL G1MAINFILE) 5.))
(SETQ G1MAXINDENTLEN (+ G1CP (* 4. (// (- G1LINELEN G1CP) 5.))))
(SETQ G1CLINE 0.)
(SETQ G1ATSTART? T)
(SETQ G1FREELEN (- G1LINELEN G1CP))
(SETQ G1PENDING 0.)
(SETQ G1WENTUP? NIL)
(SETQ G1PRINTING? (NOT (> G1PRINSTARTLINE 0.)))
(SETQ G1TABSIZE 1.)
(SETQ G1TABOFFSET 0.)
(SETQ G1INPTR -1.)
(SETQ G1PP 0.)
(SETQ G1SUPPTR 0.)
(STORE (ARRAYCALL FIXNUM G1SUPSTACK 0.) 0.)
(SETQ G1INDPTR 0.)
(STORE (ARRAYCALL FIXNUM G1INDSTACK 0.) G1CP)
(SETQ G1OPEN-DEL NIL)
(SETQ G1CLOSE-DEL NIL)
(SETQ G1FCODE 'NEVER)
(SETQ G1BCODE 0.)
(SETQ G1LEVEL G1PRINLEVEL)
(SETQ G1RINDEX 0.)
(SETQ G1EXPLODE-RESULT NIL)))
(DEFUN G1FORMAT-DISPATCH (TEMPLATE ITEM)
(COND ((HUNKP ITEM)
(COND (G1FORMAT-HUNK
(FUNCALL G1FORMAT-HUNK
(COND (TEMPLATE)
(G11LEVEL-BLOCK-TEMPLATE))
ITEM))
((G1FORMAT-HUNK (COND (TEMPLATE)
(G11LEVEL-BLOCK-TEMPLATE))
ITEM))))
((EQ (TYPEP ITEM) 'LIST)
(COND (TEMPLATE
(COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMPLATE ITEM))
((G1FORMAT-LIST TEMPLATE ITEM))))
(((LAMBDA (HEAD SYMBOL? GRIND-FN TEMPLATE)
(PROGN (SETQ HEAD (CAR ITEM))
(SETQ SYMBOL? (EQ (TYPEP HEAD) 'SYMBOL))
(SETQ GRIND-FN (COND (SYMBOL? (GET HEAD 'GGRIND-FN))))
(SETQ TEMPLATE
(COND (SYMBOL?
(COND ((GET HEAD 'GGRIND-TEMPLATE))
((GETL HEAD GFN-GRIND-PROPERTIES) G1FN-TEMPLATE)
(G1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE)))
((AND (EQ (TYPEP HEAD) 'LIST) (EQ (CAR HEAD) 'LAMBDA)) G1APPLY-TEMPLATE)
(G1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE))))
(COND (GRIND-FN (FUNCALL GRIND-FN TEMPLATE ITEM))
((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMPLATE ITEM))
((G1FORMAT-LIST TEMPLATE ITEM))))))
NIL NIL NIL NIL))))
((COND (G1FORMAT-ATOM (FUNCALL G1FORMAT-ATOM TEMPLATE ITEM))
((G1ENTER-OBJ ITEM
(COND (G1PRINC-ATOMS 'PRINC)
('PRIN1))
NIL)))))
NIL)
(DEFUN G1RCHECK (ITEM)
(COND ((OR (ATOM ITEM) (NOT G1CHECKRECURSION)) ITEM)
(T
(COND ((NOT (< G1RINDEX G1RSIZE))
(SETQ G1RSIZE (+ G1RINDEX 25.))
(*REARRAY G1PARENTS (CAR (ARRAYDIMS G1PARENTS)) G1RSIZE)))
((LAMBDA (I)
(SETQ I 0.)
(PROG NIL
U1←L (PROGN (COND ((= I G1RINDEX)
(STORE (ARRAYCALL NIL G1PARENTS I) ITEM)
(SETQ G1RINDEX (1+ G1RINDEX))
(RETURN ITEM)))
(COND ((EQ ITEM (ARRAYCALL NIL G1PARENTS I))
(RETURN (IMPLODE (APPEND '(↑) (EXPLODEN (- G1RINDEX I))))))))
(SETQ I (1+ I))
(GO U1←L)))
0.))))
(DEFUN G1FORMAT-LIST (|U1←ARG1.| LIST)
((LAMBDA (ICODE TEMP)
((LAMBDA (U1←ITEM) (SETQ ICODE (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) (SETQ TEMP U1←ITEM)) |U1←ARG1.|)
((LAMBDA (ORINDEX OLEVEL CLOSE-DEL OPEN-DEL)
(PROGN (SETQ G1OPEN-DEL NIL) (SETQ G1CLOSE-DEL NIL))
(COND ((ZEROP G1LEVEL) (G1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ LIST (G1RCHECK LIST))) (G1ENTER-OBJ LIST 'PRINC NIL))
(T
(SETQ G1LEVEL (1- G1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (CAR LIST))
(COND (G1PRINC-ATOMS (SETQ ICODE (+ ICODE 1. (FLATC (CAR LIST)))))
((SETQ ICODE (+ ICODE 1. (FLATSIZE (CAR LIST))))))))))
(G1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR OPEN-DEL '|(|) 'PRINC NIL))
((LAMBDA (I REST HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP G1LEVEL) 2.)
(G1PRINLENGTH)))
((LAMBDA (U1←ITEM)
(SETQ HEAD (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
LIST)
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
TEMP))
(PROG NIL
U1←L (PROGN (COND ((OR (MINUSP I) (AND (ZEROP I) (OR REST (NOT (ATOM HEAD)))))
(PROGN (SETQ G1FCODE FCODE
G1BCODE 0.)
(G1ENTER-OBJ '|...| 'PRINC NIL))
(RETURN NIL)))
(SETQ G1FCODE FCODE
G1BCODE
(COND ((NULL REST) 0.)
(1.)))
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH SUBTEMP HEAD))
((G1FORMAT-DISPATCH SUBTEMP HEAD)))
(COND ((NULL REST) (RETURN NIL)))
(COND ((NOT (EQ (TYPEP (SETQ REST (G1RCHECK REST))) 'LIST))
(PROGN (SETQ G1FCODE (CAAR RTEMP)
G1BCODE 1.)
(G1ENTER-OBJ '|.| 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH (CDAR RTEMP) REST))
((G1FORMAT-DISPATCH (CDAR RTEMP) REST)))
(RETURN NIL))))
(PROGN (SETQ I (1- I))
((LAMBDA (U1←ITEM)
(SETQ HEAD (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
REST)
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
RTEMP))
(GO U1←L)))
0. NIL NIL NIL NIL NIL)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR CLOSE-DEL '|)|) 'PRINC 'END))
(PROGN (SETQ G1RINDEX ORINDEX) (SETQ G1LEVEL OLEVEL)))))
G1RINDEX G1LEVEL G1CLOSE-DEL G1OPEN-DEL))
NIL NIL))
(DEFUN G1FORMAT-LSUBR NARGS
((LAMBDA (TEMP ICODE OLEVEL CLOSE-DEL OPEN-DEL)
(PROGN ((LAMBDA (U1←ITEM) (SETQ ICODE (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) (SETQ TEMP U1←ITEM))
(ARG 1.))
(SETQ OLEVEL G1LEVEL)
(SETQ CLOSE-DEL G1CLOSE-DEL)
(SETQ OPEN-DEL G1OPEN-DEL))
(PROGN (SETQ G1OPEN-DEL NIL) (SETQ G1CLOSE-DEL NIL))
(COND ((ZEROP G1LEVEL) (G1ENTER-OBJ '/# 'PRINC NIL))
(T
(SETQ G1LEVEL (1- G1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (ARG 2.))
(COND (G1PRINC-ATOMS (SETQ ICODE (+ ICODE 1. (FLATC (ARG 2.)))))
((SETQ ICODE (+ ICODE 1. (FLATSIZE (ARG 2.))))))))))
(G1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR OPEN-DEL '|(|) 'PRINC NIL))
((LAMBDA (I J HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP G1LEVEL) 2.)
(G1PRINLENGTH)))
(SETQ J 2.)
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
TEMP))
(PROG NIL
U1←L (COND ((> J NARGS) (RETURN NIL)))
(SETQ HEAD (ARG J))
(PROGN (COND ((OR (MINUSP I) (AND (ZEROP I) (OR (< J NARGS) (NOT (ATOM HEAD)))))
(PROGN (SETQ G1FCODE FCODE
G1BCODE 0.)
(G1ENTER-OBJ '|...| 'PRINC NIL))
(RETURN NIL)))
(SETQ G1FCODE FCODE
G1BCODE
(COND ((= J NARGS) 0.)
(1.)))
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH SUBTEMP HEAD))
((G1FORMAT-DISPATCH SUBTEMP HEAD))))
(PROGN (SETQ I (1- I))
(SETQ J (1+ J))
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
RTEMP))
(GO U1←L)))
0. 0. NIL NIL NIL NIL)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR CLOSE-DEL '|)|) 'PRINC 'END))
(SETQ G1LEVEL OLEVEL))))
NIL NIL NIL NIL NIL))
(DEFUN G1FORMAT-HUNK (|U1←ARG1.| HUNK)
((LAMBDA (ICODE TEMP)
((LAMBDA (U1←ITEM) (SETQ ICODE (CAR U1←ITEM)) (SETQ U1←ITEM (CDR U1←ITEM)) (SETQ TEMP U1←ITEM)) |U1←ARG1.|)
((LAMBDA (ORINDEX OLEVEL CLOSE-DEL OPEN-DEL END)
(PROGN (SETQ ORINDEX G1RINDEX)
(SETQ OLEVEL G1LEVEL)
(SETQ CLOSE-DEL G1CLOSE-DEL)
(SETQ OPEN-DEL G1OPEN-DEL)
(SETQ END (1- (HUNKSIZE HUNK))))
(PROGN (SETQ G1OPEN-DEL NIL) (SETQ G1CLOSE-DEL NIL))
(COND ((ZEROP G1LEVEL) (G1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ HUNK (G1RCHECK HUNK))) (G1ENTER-OBJ HUNK 'PRINC NIL))
(T
(SETQ G1LEVEL (1- G1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (CXR 1. HUNK))
(COND (G1PRINC-ATOMS (SETQ ICODE (+ ICODE 1. (FLATC (CXR 1. HUNK)))))
((SETQ ICODE (+ ICODE 1. (FLATSIZE (CXR 1. HUNK))))))))))
(G1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR OPEN-DEL '{) 'PRINC NIL))
((LAMBDA (I J HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP G1LEVEL) 2.)
(G1PRINLENGTH)))
(SETQ J 1.)
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
TEMP))
(PROG NIL
U1←L (COND ((> J END) (RETURN NIL)))
(SETQ HEAD (CXR J HUNK))
(PROGN (SETQ TEMP RTEMP)
(COND ((OR (MINUSP I) (AND (ZEROP I) (OR (< J END) (NOT (ATOM HEAD)))))
(PROGN (SETQ G1FCODE FCODE
G1BCODE 0.)
(G1ENTER-OBJ '|...| 'PRINC NIL))
(RETURN NIL)))
(SETQ G1FCODE FCODE
G1BCODE 1.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH SUBTEMP HEAD))
((G1FORMAT-DISPATCH SUBTEMP HEAD))))
(PROGN (SETQ I (1- I))
(SETQ J (1+ J))
((LAMBDA (U1←ITEM)
((LAMBDA (U1←ITEM)
(SETQ FCODE (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ SUBTEMP U1←ITEM))
(CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ RTEMP U1←ITEM))
RTEMP))
(GO U1←L)))
0. 0. NIL NIL NIL NIL)
(SETQ G1FCODE (CAAR TEMP)
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH (CDAR TEMP) (CXR 0. HUNK)))
((G1FORMAT-DISPATCH (CDAR TEMP) (CXR 0. HUNK))))
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ (OR CLOSE-DEL '}) 'PRINC 'END))
(PROGN (SETQ G1RINDEX ORINDEX) (SETQ G1LEVEL OLEVEL)))))
NIL NIL NIL NIL 0.))
NIL NIL))
(DEFUN (GMAKE-INVERT-QUOTE-FN MACRO) (U1←BODY)
((LAMBDA (ATOM OPEN-DEL CLOSE-DEL)
(COND ((NOT ((LAMBDA (U1←ITEM)
(AND (NOT (ATOM U1←ITEM))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) (NOT (ATOM U1←ITEM)))
(PROGN (SETQ ATOM (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(NOT (ATOM U1←ITEM)))
(PROGN (SETQ OPEN-DEL (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(OR (AND (NOT (ATOM U1←ITEM))
(PROGN (SETQ CLOSE-DEL (CAR U1←ITEM)) (NULL (CDR U1←ITEM))))
T))))
U1←BODY))
(ERROR 'BAD-ARGS-TO-GMAKE-INVERT-QUOTE-FN (LIST U1←BODY))))
((LAMBDA (X Y) (RPLACA X (CAR Y)) (RPLACD X (CDR Y))) U1←BODY
(COND (CLOSE-DEL
(LIST 'DEFUN
(LIST* ATOM '(GGRIND-FN))
'(TEMP ITEM)
(LIST* 'COND
(LIST* '(CDR ITEM)
(LIST 'SETQ
'G1OPEN-DEL
(LIST 'QUOTE OPEN-DEL)
'G1CLOSE-DEL
(LIST 'QUOTE CLOSE-DEL))
'((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP (CDR ITEM))))))
'(((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP ITEM))))))))
((LIST 'DEFUN
(LIST* ATOM '(GGRIND-FN))
'(TEMP ITEM)
(LIST* 'COND
(LIST* '(AND (CDR ITEM) (NULL (CDDR ITEM)))
(LIST* 'SETQ
'G1OPEN-DEL
(LIST 'QUOTE OPEN-DEL)
'(G1CLOSE-DEL '|| G1LEVEL (1+ G1LEVEL)))
'((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP (CDR ITEM))))
(SETQ G1LEVEL (1- G1LEVEL))))
'(((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP ITEM)))))))))))
NIL NIL NIL))
(DEFUN (QUOTE GGRIND-FN) (TEMP ITEM)
(COND ((AND (CDR ITEM) (NULL (CDDR ITEM)))
(SETQ G1OPEN-DEL '/'
G1CLOSE-DEL '||
G1LEVEL (1+ G1LEVEL))
(COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP (CDR ITEM))))
(SETQ G1LEVEL (1- G1LEVEL)))
((COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP (CDR ITEM)))
((G1FORMAT-LIST TEMP ITEM))))))
(DEFUN (GMAKE-INVERT-QUOTE-FN2 MACRO) (U1←BODY)
((LAMBDA (INTERNAL-ATOM EXTERNAL-ATOM)
(COND ((NOT ((LAMBDA (U1←ITEM)
(AND (NOT (ATOM U1←ITEM))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) (NOT (ATOM U1←ITEM)))
(PROGN (SETQ INTERNAL-ATOM (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(NOT (ATOM U1←ITEM)))
(PROGN (SETQ EXTERNAL-ATOM (CAR U1←ITEM)) (NULL (CDR U1←ITEM)))))
U1←BODY))
(ERROR 'BAD-ARGS-TO-GMAKE-INVERT-QUOTE-FN2 (LIST U1←BODY))))
((LAMBDA (X Y) (RPLACA X (CAR Y)) (RPLACD X (CDR Y))) U1←BODY
(LIST* 'DEFUN
(LIST* INTERNAL-ATOM '(GGRIND-FN))
'(TEMP ITEM)
'(G1ENTER-OBJ 0. NIL 'START)
(LIST* 'G1ENTER-FORMAT&OBJ ''NEVER '0. (LIST 'QUOTE EXTERNAL-ATOM) '('PRINC NIL))
'((G1ENTER-FORMAT 'NEVER 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP (CDR ITEM)))
((G1FORMAT-DISPATCH TEMP (CDR ITEM))))
(G1ENTER-OBJ '|| 'PRINC 'END)))))
NIL NIL))
(DEFUN (|`-expander/|| GGRIND-FN) (TEMP ITEM)
(G1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '/` 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP (CDR ITEM)))
((G1FORMAT-DISPATCH TEMP (CDR ITEM))))
(G1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN (|`,/|| GGRIND-FN) (TEMP ITEM)
(G1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '/, 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP (CDR ITEM)))
((G1FORMAT-DISPATCH TEMP (CDR ITEM))))
(G1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN (|`,@/|| GGRIND-FN) (TEMP ITEM)
(G1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '/,@ 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP (CDR ITEM)))
((G1FORMAT-DISPATCH TEMP (CDR ITEM))))
(G1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN (|`,./|| GGRIND-FN) (TEMP ITEM)
(G1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '|,.| 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP (CDR ITEM)))
((G1FORMAT-DISPATCH TEMP (CDR ITEM))))
(G1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN (DEFUN GGRIND-FN) (TEMP ITEM)
(SETQ TEMP
(COND ((AND ((LAMBDA (U1←ITEM)
(AND (NOT (ATOM U1←ITEM))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) (NOT (ATOM U1←ITEM)))
(PROGN (SETQ U1←ITEM (CDR U1←ITEM)) (NOT (ATOM U1←ITEM)))))
ITEM)
(OR (MEMQ (CADR ITEM) '(EXPR FEXPR MACRO)) (MEMQ (CADDR ITEM) '(EXPR FEXPR MACRO))))
G1DEFUN2-TEMPLATE)
(G1DEFUN1-TEMPLATE)))
(COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST TEMP ITEM))
((G1FORMAT-LIST TEMP ITEM))))
(DEFUN (MACROEXPANDED GGRIND-FN) (TEMP ITEM)
(SETQ ITEM
(COND (GRIND-MACROEXPANDED (CADDDR (CDR ITEM)))
(T (CADDDR ITEM))))
(SETQ G1LEVEL (1+ G1LEVEL))
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH TEMP ITEM))
((G1FORMAT-DISPATCH TEMP ITEM)))
(SETQ G1LEVEL (1- G1LEVEL)))
(DEFUN (PROG GGRIND-FN) (UNUSED-TEMPLATE LIST)
(COND (((LAMBDA (OVERVAR← ← I OVER-ACC)
(PROGN (SETQ OVERVAR← (CDDR LIST)) (SETQ I 0.) (SETQ OVER-ACC T))
(PROG NIL
U1←L (COND ((ATOM OVERVAR←) (RETURN OVER-ACC)))
(SETQ ← (CAR OVERVAR←))
(SETQ OVER-ACC (OR (PROGN (COND ((> I 10.) (RETURN NIL))) (NOT (ATOM ←))) (RETURN NIL)))
(PROGN (SETQ OVERVAR← (CDR OVERVAR←)) (SETQ I (1+ I)))
(GO U1←L)))
NIL NIL 0. NIL)
(COND (G1FORMAT-LIST (FUNCALL G1FORMAT-LIST G1FN-TEMPLATE LIST))
((G1FORMAT-LIST G1FN-TEMPLATE LIST))))
(((LAMBDA (ORINDEX OLEVEL DEFAULT-BCODE BCODE ANY-LABS-YET?)
(PROGN (SETQ ORINDEX G1RINDEX) (SETQ OLEVEL G1LEVEL) (SETQ ANY-LABS-YET? NIL))
(COND (G1PRINC-ATOMS (SETQ DEFAULT-BCODE (1+ (FLATC (CAR LIST)))))
((SETQ DEFAULT-BCODE (1+ (FLATSIZE (CAR LIST))))))
(SETQ BCODE DEFAULT-BCODE)
(COND ((ZEROP G1LEVEL) (G1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ LIST (G1RCHECK LIST))) (G1ENTER-OBJ LIST 'PRINC NIL))
(T
(SETQ G1LEVEL (1- G1LEVEL))
(G1ENTER-OBJ 1. NIL 'START)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '|(| 'PRINC NIL))
((LAMBDA (I REST HEAD K)
(PROGN (SETQ I
(COND ((ZEROP G1LEVEL) 2.)
(G1PRINLENGTH)))
((LAMBDA (U1←ITEM)
(SETQ HEAD (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
LIST)
(SETQ K 1.))
(PROG NIL
U1←L (PROGN (COND ((OR (MINUSP I) (AND (ZEROP I) (OR REST (NOT (ATOM HEAD)))))
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '|...| 'PRINC NIL))
(RETURN NIL)))
(COND ((MINUSP K)
(COND ((AND (ATOM HEAD) HEAD)
(COND (G1PRINC-ATOMS (SETQ BCODE (- BCODE 1. (FLATC HEAD))))
((SETQ BCODE (- BCODE 1. (FLATSIZE HEAD)))))
(PROGN (SETQ G1FCODE
(COND (ANY-LABS-YET? 'NEVER)
('ALWAYS))
G1BCODE 1.)
(G1ENTER-OBJ HEAD
(COND (G1PRINC-ATOMS 'PRINC)
('PRIN1))
NIL))
(SETQ ANY-LABS-YET? T))
(T
(COND ((NOT ANY-LABS-YET?)
(PROGN (SETQ G1FCODE 'ALWAYS
G1BCODE DEFAULT-BCODE)
(G1ENTER-OBJ '|| NIL NIL)))
(T
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE (MAX 0. BCODE))
(G1ENTER-OBJ '|| NIL NIL))
(PROGN (SETQ BCODE DEFAULT-BCODE) (SETQ ANY-LABS-YET? NIL))))
(SETQ G1FCODE 'NEVER
G1BCODE
(COND ((NULL REST) 0.)
(1.)))
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH NIL HEAD))
((G1FORMAT-DISPATCH NIL HEAD))))))
(T
(SETQ G1FCODE 'NEVER
G1BCODE
(COND ((NULL REST) 0.)
(1.)))
(COND (G1FORMAT-DISPATCH
(FUNCALL G1FORMAT-DISPATCH G11LEVEL-BLOCK-TEMPLATE HEAD))
((G1FORMAT-DISPATCH G11LEVEL-BLOCK-TEMPLATE HEAD)))))
(COND ((NULL REST) (RETURN NIL)))
(COND ((NOT (EQ (TYPEP (SETQ REST (G1RCHECK REST))) 'LIST))
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 1.)
(G1ENTER-OBJ '|.| 'PRINC NIL))
(SETQ G1FCODE 'NEVER
G1BCODE 0.)
(COND (G1FORMAT-DISPATCH (FUNCALL G1FORMAT-DISPATCH NIL REST))
((G1FORMAT-DISPATCH NIL REST)))
(RETURN NIL))))
(PROGN (SETQ I (1- I))
((LAMBDA (U1←ITEM)
(SETQ HEAD (CAR U1←ITEM))
(SETQ U1←ITEM (CDR U1←ITEM))
(SETQ REST U1←ITEM))
REST)
(SETQ K (1- K)))
(GO U1←L)))
0. NIL NIL 0.)
(PROGN (SETQ G1FCODE 'NEVER
G1BCODE 0.)
(G1ENTER-OBJ '|)| 'PRINC 'END))
(PROGN (SETQ G1RINDEX ORINDEX) (SETQ G1LEVEL OLEVEL)))))
NIL NIL 0. 0. NIL))))
(PUTPROP 'DO (GET 'PROG 'GGRIND-FN) 'GGRIND-FN)
(DEFUN G1ENTER-OBJ (OBJ PCODE LCODE)
((LAMBDA (FLAG LENGTH)
(PROGN (SETQ FLAG
(+ (COND ((EQ PCODE 'PRIN1) (PROGN 4096.))
((EQ PCODE 'PRINC) (PROGN 2048.))
(0.))
(COND ((EQ G1FCODE 'NEVER) (PROGN 512.))
((EQ G1FCODE 'NORMAL) (PROGN 128.))
((EQ G1FCODE 'TBLOCK) (PROGN 1024.))
((EQ G1FCODE 'BLOCK) (PROGN 256.))
((PROGN 64.)))
(COND ((EQ LCODE 'START) (PROGN 8192.))
((EQ LCODE 'END) (+ 49152. (ARRAYCALL FIXNUM G1BCODESTACK G1SUPPTR)))
((+ 32768. G1BCODE)))))
(SETQ LENGTH
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG))) 0.)
((NOT (ZEROP (BOOLE 1. 4096. FLAG))) (+ (BOOLE 1. 63. FLAG) (FLATSIZE OBJ)))
((NOT (ZEROP (BOOLE 1. 2048. FLAG))) (+ (BOOLE 1. 63. FLAG) (FLATC OBJ)))
((BOOLE 1. 63. FLAG)))))
(COND (G1EXPLODING
(COND ((NOT (ZEROP (BOOLE 1. 2048. FLAG)))
(SETQ G1EXPLODE-RESULT (NRECONC (EXPLODEC OBJ) G1EXPLODE-RESULT)))
((NOT (ZEROP (BOOLE 1. 4096. FLAG)))
(SETQ G1EXPLODE-RESULT (NRECONC (EXPLODE OBJ) G1EXPLODE-RESULT))))
((LAMBDA (I)
(SETQ I (BOOLE 1. 63. FLAG))
(PROG NIL
U1←L (COND ((NOT (PLUSP I)) (RETURN NIL)))
(SETQ G1EXPLODE-RESULT (CONS '| | G1EXPLODE-RESULT))
(SETQ I (1- I))
(GO U1←L)))
0.)
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(PROGN (SETQ G1SUPPTR (1+ G1SUPPTR)) (STORE (ARRAYCALL FIXNUM G1BCODESTACK G1SUPPTR) G1BCODE)))
((NOT (ZEROP (BOOLE 1. 16384. FLAG))) (SETQ G1SUPPTR (1- G1SUPPTR)))))
(T
(PROGN (SETQ G1INPTR (1+ G1INPTR))
(STORE (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR) (1+ (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR))))
(COND ((NOT (< G1INPTR G1SIZE))
(COND ((< G1PP 10.)
(SETQ G1SIZE (+ G1SIZE 10.))
(*REARRAY G1OBJ (CAR (ARRAYDIMS G1OBJ)) G1SIZE)
(*REARRAY G1FLAG (CAR (ARRAYDIMS G1FLAG)) G1SIZE)
(*REARRAY G1LENGTH (CAR (ARRAYDIMS G1LENGTH)) G1SIZE))
(T
((LAMBDA (J I)
(PROGN (SETQ J G1PP) (SETQ I 0.))
(PROG NIL
U1←L (COND ((= J G1SIZE) (RETURN NIL)))
(PROGN (STORE (ARRAYCALL NIL G1OBJ I) (ARRAYCALL NIL G1OBJ J))
(STORE (ARRAYCALL FIXNUM G1FLAG I) (ARRAYCALL FIXNUM G1FLAG J))
(STORE (ARRAYCALL FIXNUM G1LENGTH I) (ARRAYCALL FIXNUM G1LENGTH J)))
(PROGN (SETQ J (1+ J)) (SETQ I (1+ I)))
(GO U1←L)))
0. 0.)
(PROGN (SETQ G1INPTR (- G1INPTR G1PP)) (SETQ G1PP 0.))))))
(PROGN (STORE (ARRAYCALL NIL G1OBJ G1INPTR) OBJ)
(STORE (ARRAYCALL FIXNUM G1FLAG G1INPTR) FLAG)
(STORE (ARRAYCALL FIXNUM G1LENGTH G1INPTR) LENGTH))
((LAMBDA (I J)
(PROGN (SETQ I G1SUPPTR) (SETQ J (- G1INPTR (ARRAYCALL FIXNUM G1SUPSTACK I))))
(PROG NIL
U1←L (COND ((OR (ZEROP I) (< J G1PP)) (RETURN NIL)))
(STORE (ARRAYCALL FIXNUM G1LENGTH J) (+ LENGTH (ARRAYCALL FIXNUM G1LENGTH J)))
(PROGN (SETQ I (1- I)) (SETQ J (- J (ARRAYCALL FIXNUM G1SUPSTACK I))))
(GO U1←L)))
0. 0.)
(COND ((NOT (ZEROP (BOOLE 1. 64. FLAG)))
((LAMBDA (I J)
(PROGN (SETQ I G1SUPPTR) (SETQ J (- G1INPTR (ARRAYCALL FIXNUM G1SUPSTACK I))))
(PROG NIL
U1←L (COND ((OR (ZEROP I) (< J G1PP)) (RETURN NIL)))
(STORE (ARRAYCALL FIXNUM G1FLAG J) (+ 65536. (ARRAYCALL FIXNUM G1FLAG J)))
(PROGN (SETQ I (1- I)) (SETQ J (- J (ARRAYCALL FIXNUM G1SUPSTACK I))))
(GO U1←L)))
0. 0.)))
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(SETQ G1SUPPTR (1+ G1SUPPTR))
(COND ((NOT (< G1SUPPTR G1SUPSIZE))
(SETQ G1SUPSIZE (+ G1SUPSIZE 10.))
(*REARRAY G1SUPSTACK (CAR (ARRAYDIMS G1SUPSTACK)) G1SUPSIZE)
(*REARRAY G1INDSTACK (CAR (ARRAYDIMS G1INDSTACK)) G1SUPSIZE)
(*REARRAY G1BCODESTACK (CAR (ARRAYDIMS G1BCODESTACK)) G1SUPSIZE)))
(PROGN (STORE (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR) 0.)
(STORE (ARRAYCALL FIXNUM G1BCODESTACK G1SUPPTR) G1BCODE)))
((NOT (ZEROP (BOOLE 1. 16384. FLAG)))
((LAMBDA (I)
(COND ((NOT (> G1PP I))
(STORE (ARRAYCALL FIXNUM G1FLAG I) (+ 32768. (ARRAYCALL FIXNUM G1FLAG I))))))
(- G1INPTR (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR)))
(PROGN (SETQ G1SUPPTR (1- G1SUPPTR))
(STORE (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR)
(+ (ARRAYCALL FIXNUM G1SUPSTACK G1SUPPTR)
(ARRAYCALL FIXNUM G1SUPSTACK (1+ G1SUPPTR)))))))
(G1PRINTOUT))))
NIL 0.)
NIL)
(DEFUN G1PRINTOUT NIL
((LAMBDA (FLAG)
(PROG NIL
U1←L (COND ((> G1PP G1INPTR) (RETURN NIL)))
(SETQ FLAG (ARRAYCALL FIXNUM G1FLAG G1PP))
(COND ((AND (NOT (ZEROP (BOOLE 1. 1024. FLAG))) (NOT (ZEROP (BOOLE 1. 32768. FLAG))) (= G1TABSIZE 1.))
((LAMBDA (N I MAX SPACE)
(PROGN (SETQ N (MAX 2. (ARRAYCALL FIXNUM G1LENGTH G1PP)))
(SETQ I 0.)
(SETQ MAX
((LAMBDA (J FLAG)
(SETQ J G1PP)
(PROG NIL
U1←L (COND ((> J G1INPTR) (RETURN N)))
(SETQ FLAG (ARRAYCALL FIXNUM G1FLAG J))
(PROGN (COND ((= I 0.) (SETQ N (MAX N (ARRAYCALL FIXNUM G1LENGTH J)))))
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG))) (SETQ I (1+ I)))
((NOT (ZEROP (BOOLE 1. 16384. FLAG))) (SETQ I (1- I)))))
(SETQ J (1+ J))
(GO U1←L)))
0. NIL))
(SETQ SPACE (- G1LINELEN (ARRAYCALL FIXNUM G1INDSTACK G1INDPTR))))
(PROGN (SETQ MAX (MIN SPACE (+ MAX (// MAX 5.))))
(SETQ G1TABSIZE (// SPACE (// SPACE MAX)))
(SETQ G1TABOFFSET (- (\ SPACE G1TABSIZE) G1TABSIZE))))
0. 0. 0. 0.)))
(COND ((NOT G1ATSTART?)
(COND ((AND (NOT (ZEROP (BOOLE 1. 1024. FLAG))) (NOT (ZEROP (BOOLE 1. 32768. FLAG))))
((LAMBDA (J) (PROGN (SETQ G1PENDING (+ G1PENDING J)) (SETQ G1FREELEN (- G1FREELEN J))))
(\ (- G1FREELEN G1TABOFFSET) G1TABSIZE))))
(COND ((OR (NOT (ZEROP (BOOLE 1. 64. FLAG)))
(NOT (ZEROP (BOOLE 1. 128. FLAG)))
(AND (OR (NOT (ZEROP (BOOLE 1. 256. FLAG))) (NOT (ZEROP (BOOLE 1. 1024. FLAG))))
(OR G1WENTUP?
(NOT (ZEROP (BOOLE 1. 65536. FLAG)))
(AND (> (ARRAYCALL FIXNUM G1LENGTH G1PP) G1FREELEN)
(< (ARRAYCALL FIXNUM G1INDSTACK G1INDPTR) (- G1LINELEN G1FREELEN)))))
(AND (NOT (ZEROP (BOOLE 1. 512. FLAG)))
(NOT (NOT (ZEROP (BOOLE 1. 8192. FLAG))))
(> (ARRAYCALL FIXNUM G1LENGTH G1PP) (+ 4. G1FREELEN))
(< (ARRAYCALL FIXNUM G1INDSTACK G1INDPTR) (- G1LINELEN G1FREELEN))))
(PROGN (SETQ G1ATSTART? T)
(SETQ G1WENTUP? NIL)
(SETQ G1CLINE (1+ G1CLINE))
(SETQ G1PENDING (ARRAYCALL FIXNUM G1INDSTACK G1INDPTR))
(SETQ G1FREELEN (- G1LINELEN G1PENDING)))
(COND ((> G1CLINE G1PRINENDLINE) (THROW '|G1prinendline exceeded| G1PRINTABORT)))
(COND (G1PRINTING? (TERPRI G1FILES))
((SETQ G1PRINTING? (NOT (> G1PRINSTARTLINE G1CLINE)))
(SETQ G1PENDING (- G1PENDING G1CP))))))))
(COND ((AND (NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(OR (NOT (ZEROP (BOOLE 1. 65536. FLAG))) (> (ARRAYCALL FIXNUM G1LENGTH G1PP) G1FREELEN)))
(PROGN (SETQ G1INDPTR (1+ G1INDPTR))
(STORE (ARRAYCALL FIXNUM G1INDSTACK G1INDPTR)
((LAMBDA (I)
(COND ((> I G1MAXINDENTLEN) (SETQ I 3.)))
(SETQ I (+ I (- G1LINELEN G1FREELEN)))
(SETQ I (MAX G1CP I))
(COND ((> I G1MAXINDENTLEN)
(SETQ I (+ G1CP (// (- G1LINELEN G1CP) 5.) (\ I G1MAXINDENTLEN)))))
I)
(ARRAYCALL NIL G1OBJ G1PP)))
(SETQ G1PP (1+ G1PP))
(SETQ G1TABSIZE 1.)))
((NOT (ZEROP (BOOLE 1. 32768. FLAG)))
(PROGN (SETQ G1FREELEN (- G1FREELEN (ARRAYCALL FIXNUM G1LENGTH G1PP))) (SETQ G1ATSTART? NIL))
((LAMBDA (I)
(SETQ I 0.)
(PROG NIL
U1←L (COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG))) (SETQ I (1+ I)))
(T
(COND ((NOT (ZEROP (BOOLE 1. 16384. FLAG))) (SETQ I (1- I))))
(COND (G1PRINTING?
((LAMBDA (J)
(SETQ J G1PENDING)
(PROG NIL
U1←L (COND ((NOT (PLUSP J)) (RETURN NIL)))
(TYO 32. G1FILES)
(SETQ J (1- J))
(GO U1←L)))
0.)
(COND ((NOT (ZEROP (BOOLE 1. 2048. FLAG)))
(PRINC (ARRAYCALL NIL G1OBJ G1PP) G1FILES))
((NOT (ZEROP (BOOLE 1. 4096. FLAG)))
(PRIN1 (ARRAYCALL NIL G1OBJ G1PP) G1FILES)))))
(SETQ G1PENDING (BOOLE 1. 63. FLAG))))
(SETQ G1PP (1+ G1PP))
(COND ((ZEROP I) (RETURN NIL))
((MINUSP I)
(PROGN (SETQ G1INDPTR (1- G1INDPTR)) (SETQ G1WENTUP? T) (SETQ G1TABSIZE 64000.))
(RETURN NIL)))
(SETQ FLAG (ARRAYCALL FIXNUM G1FLAG G1PP))
(GO U1←L)))
0.))
((RETURN NIL)))
(GO U1←L)))
NIL))
))
ββββ